/* Output from p2c, the Pascal-to-C translator */
/* From input file "rpcc.p" */
/********************************************************************
* 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.
***********************************************************************/
#include <p2c/p2c.h>
/** Global declaration **/
/********************************************************************
Top-down RPC compiler - Declaration part
History:
28 May 86 Written, Antonio Pastore, technical Student, DD/OC
11 Jul 86 Last update by Antonio
2 Nov 86 Options concurrent, sm6809, cm6809 added
10 Aug 87 genericC options added; structural changes - Nici.
17 Aug 87 byvalue option added - Nici.
26 Aug 87 Options timeout and version added - Nici.
1 Sep 87 Options types and <s,c>pcturbo added - Nici.
26 Aug 88 Options <s,c>macturbo added. Roberto Bagnara, DD/OC
1 Nov 88 Options <s,c>pils added. TBL, LT.
30 Mar 89 CAST option added - TBL
*/
#define rpc_name_length 40 /* Must tally with RPC$CONST! */
#define MAXSTRING 255
#define expression_length 80
/* expression for compenent of composite type*/
#define template_length 10 /* Length of expression templates */
#define error_length 48 /* Length of code generator error string */
#define MAXIDLEN 25
#define NUMKEYWORD 27 /* Must = number of keywords in INIT */
#define NUMOMODES 11 /* " " " " " output_mode */
#define MAXDIM 9
#define NON_FRAGMENTATION_LIMIT 1488
/* RPC_BUFFER_SIZE-CALL_HEADER_LENGTH
in the worst case */
#define FRAGMENTATION_THRESHOLD 150 /* Can break up types over this size */
#define rpc_default_timeout (-1) /* Must agree with include files */
/* The following constant should be set to take parameters from the
command line.
*/
#define COMMANDLINE true
typedef Char longstring[MAXSTRING];
typedef Char char_name[MAXIDLEN];
typedef Char char3[3];
typedef Char opt_name[10];
typedef Char template_type[template_length];
typedef Char error_string[error_length];
typedef struct astring {
Char str[MAXSTRING];
long len;
} astring;
typedef struct pilstring {
Char str[MAXSTRING];
long start, len;
} pilstring;
typedef struct id_name {
char_name str;
long len;
} id_name;
typedef struct expression {
Char str[expression_length];
long len;
} expression;
/** Types related to lexical analizer and tokens **/
/******
* WARNING!!!
* Be careful when changing the order of the following declaration!!
*******/
/* First token, simple type, courier type */
/* Last simple type */
/* RECORD added 23 Oct TBL */
/* POINTER . . . */
/* Last courier type */
/* First attr_type */
/* Last attr_type */
/* add new tokens here */
typedef enum {
chartok, bytetok, shortok, integertok, real32tok, real48tok, real64tok,
real128tok, longtok, arraytok, recordtok, accesstok, sequence, stringtok,
substring, package, semicolon, istok, typetok, endtok, colon, comma,
opnround, clsround, oftok, intok, outok, inoutok, dot, ident, number,
proctok, functok, return_, pragmatok, nultok
} type_token; /* Last type */
/* p2c: rpcc.p, line 159:
* Note: Line breaker spent 0.2+1.11 seconds, 597 tries on line 155 [251] */
typedef struct token_descriptor {
type_token kind;
union {
id_name name;
long value;
} UU;
} token_descriptor;
/* Describes: an abstract data type */
/*defined_type*/
typedef struct defined_type {
struct named_type *typ_name; /* The name if any */
long typ_min_size; /* the minimum size in bytes */
long typ_max_size; /* The maximum size in bytes */
long typ_nesting; /* Number of indeces needed */
struct defined_type *typ_subtype; /* Subtype for complex types */
boolean typ_external; /* External marshalling */
/* The type represented by this */
type_token typ_basic_type;
union {
struct {
/* low is always 1 */
/* low is always 1 */
/* low is always 1 */
/* low and high can vary */
long typ_low, typ_high; /* array bounds */
} U12;
struct named_type *typ_fields; /* List of subtypes */
} UU;
} defined_type;
/* Descibes: a Named type
*/
typedef struct named_type {
struct named_type *nty_next;
id_name nty_name;
defined_type *nty_type;
} named_type;
/* Describes: one parameter of a procedure/function
*/
typedef struct id_list {
struct id_list *next;
id_name name;
type_token attr;
defined_type *id_type;
} id_list;
/* Describes: one procedure or function
*/
typedef struct block_table {
struct block_table *next;
id_name name;
type_token b_type;
type_token return_;
id_list *list;
boolean in_only; /* no data returned */
long blk_nesting; /* Number of indeces */
long blk_min_in, blk_max_in; /* Tot Parameter size */
long blk_min_out, blk_max_out; /* Tot Parameter size */
long blk_timeout; /* Overall timeout */
id_list *blk_status_param; /* Status parameter */
boolean blk_concurrent; /* Concurrent execution*/
boolean blk_cast; /* CAST(one way message)*/
} block_table;
/* Error Codes:
*/
/** WARNING!
* Do not change the first and the last element of the following list!
**/
typedef enum {
ill_basic_type, number_req, oftok_miss, simtype_req, blocks_req, ident_req,
twice_declared, semicol_miss, var_attr_req, colon_miss, id_not_declared,
clsround_miss, opnround_miss, package_miss, endtok_miss, char_ignored,
params_miss, input_miss, comma_miss, semic_round_miss, toomany_dim,
toomany_dig, proc_exp, cant_opn_input, cant_opn_client, cant_opn_server,
cant_cls_client, cant_cls_server, dot_miss, positive_req, cant_cls_input,
ident_reserved, istok_miss, record_miss, invalid_range, bad_proc_decl,
bad_name, type_miss, return_miss, cant_opn_ext, internal_error,
bad_input_name, cant_cls_ext, unexp_eof
/* p2c: rpcc.p, line 321: Note:
* Line breaker spent 7.6+0.43 seconds, 5000 tries on line 250 [251] */
} err_type;
typedef enum {
rewriting, resetting
} open_mode;
/* *** WARNING: IF YOU MODIFY THIS DECLARATION:-
1. Check that NUMOMODES in the constant section matches the number of entries
2. Check that order of the the server and client options below matches - Nici
*/
/* ** SEE Note: */
typedef enum {
cerncross, m6809, monolith, vaxvms, vaxpas, unixbsd, pcturbo, macturbo,
pils, vaxfor, genericc
} output_mode;
/******
* WARNING!!!
* Think carefully before changing the order of the following declaration!!! (AP)
*******/
/* See output_mode */
/* add new options here */
typedef enum {
ccerncross, cm6809, cmonolith, cvaxvms, cvaxpas, cunixbsd, cpcturbo,
cmacturbo, cpils, cvaxfor, cgenericc, scerncross, sm6809, smonolith,
svaxvms, svaxpas, sunixbsd, spcturbo, smacturbo, spils, svaxfor, sgenericc,
dlex, dlexhot, dtree, shortint, stdescr, concurrent, noautoinit, byvalue,
timeout, version, types, invalid
/* p2c: rpcc.p, line 321:
* Note: Line breaker spent 1.0+0.82 seconds, 575 tries on line 283 [251] */
} options;
/** deb_lex For lexical analizer **/
/** deb_lex_hot Prints each character read from input **/
/** deb_tree To print trees created by parse **/
/*
cerncross Cern Cross Software enviroment
m6809 Omegasoft Pascal for the m6809
monolith Any monolithic Pascal compiler
vaxvms Vax/Vms pascal fortran-like
vaxpas Vax/Vms pascal
unixbsd Unix BSD enviroment
pcturbo IBM PC Turbo Pascal
macturbo Macintosh Turbo Pascal
pils Any standard PILS environonment
vaxfor VAX/FORTRAN under VMS (might be portable)
genericc Any generic C compiler
shortint forces short (16 bit) rpc_integer
stdescr pass strings by descriptor (not implemented yet)
concurrent return before processing if all parameters IN
noautoinit supress automatic initialisation of stubs (VMS)
byvalue pass all simple type parameters by value - Nici.
timeout specify value of timeout parameter - Nici.
version control stub version number handling - Nici.
types include user types in ".ext" file - Nici.
*/
typedef struct _REC_keyword {
char_name name;
type_token symbol;
} _REC_keyword;
typedef struct _REC_runoptions {
opt_name name;
boolean value;
} _REC_runoptions;
/** This variable is the HEAD pointer to the TYPE's list table **/
Static named_type *typeptr;
/** This variable is the HEAD pointer to the BLOCK's list table **/
Static block_table *blockptr;
Static id_name unitname; /** Name of the unit under analysis **/
/** Vars related to lexical analizer and tokens **/
Static long checksum; /** used for stub version number **/
Static boolean is_blank; /** for skipping multiple blanks **/
Static Char ch_there; /** for read-ahead in getchar(); **/
Static Char lastcar; /** Last char read **/
Static Char oldchar; /** Char ready for next request **/
Static boolean char_ready; /** Is a char ready to be returned? **/
Static boolean incomment; /** We are checking for comment **/
Static long lastindex; /** Index to the last token read **/
Static token_descriptor token, lastoken;
Static boolean tok_present;
/** If a token already present in lex-analizer **/
Static long lineread; /** Number of line read **/
Static long maxkeyword;
/** Number of keyword,
should be the same as NUMKEYWORD **/
Static _REC_keyword keyword[NUMKEYWORD];
Static Char upkpck[2][3]; /*'upk','pck'*/
Static defined_type *simple_descriptor[(long)longtok - (long)chartok + 1];
/* Reference definitions of simple types */
/* Variables set by parser:
*/
Static boolean external_marshalling; /* has been invoked */
Static long number_of_invented_types; /* Used by ensure_named_type */
/** General flag for errors **/
Static long errorfound;
/** File variables **/
Static FILE *inp_file; /** Input file **/
Static astring inp_name; /** Input file name **/
Static pilstring inp_line; /** Last line read **/
Static FILE *op_file; /** Output file for stub &c **/
Static astring cli_name; /** Client file name **/
Static astring ser_name; /** Server file name **/
Static astring ext_name; /** External declaration file **/
/* Variables for use by Code generator:
*/
Static long next_label; /** Next label value for use in FORTRAN **/
Static long size_so_far; /** Number of bytes packed/unpacked so far **/
Static boolean fragmentation_used;
/** have we resorted to fragmentation? **/
/* General options
*/
Static boolean deref, dr_tmp; /** dereferencing flag for C params **/
Static boolean cli_spec, ser_spec; /** forbid multiple stub generation **/
Static output_mode omode, ser_mode, cli_mode;
Static boolean client; /** We are making a client stub now **/
Static long Cmode; /** must contain all C output modes **/
Static long timeout_val; /** value of timeout, if specified **/
Static long version_num; /** stub version number, if given **/
/** Debugging variables **/
Static _REC_runoptions runoptions[(long)invalid - (long)ccerncross + 1];
/** Error management **/
/********************************************************************
* Top-down RPC compiler - Error management
*
* Author:
* Antonio Pastore, Tec. Student 1986, DD/OC, CERN
28 May 1986 Written, AP
23 Nov 1988 'expected' written, find_tok made less verbose. TBL
***********************************************************************/
Static Void getoken PV();
Static Void backtoken PV();
Static Void error(which)
err_type which;
{
printf("ERROR: ");
errorfound++;
if ((unsigned long)which > (int)unexp_eof) {
printf(
"RPCC: Panic: compiler internal error, notify the compiler's Administrator.\n");
return;
}
switch (which) {
case ill_basic_type:
printf("Illegal basic type.\n");
break;
case invalid_range:
printf("Upper bound must be greater then lower.\n");
break;
case number_req:
printf("Number requested.\n");
break;
case oftok_miss:
printf("Keyword \"of\" missing.\n");
break;
case simtype_req:
printf("Simple type requested.\n");
break;
case positive_req:
printf("Index must be positive.\n");
break;
case ident_req:
printf("Identifier requested.\n");
break;
case blocks_req:
printf("At least a procedure/function declaration requested.\n");
break;
case bad_proc_decl:
printf("Parameter must be simple or already declared in type section.\n");
break;
case twice_declared:
printf("Identifier already declared.\n");
break;
case semicol_miss:
printf("Semicolon \";\" missing.\n");
break;
case semic_round_miss:
printf("Semicolon \";\" or round bracket \")\" missing.\n");
break;
case comma_miss:
printf("Comma \",\" missing.\n");
break;
case var_attr_req:
printf("\"in\",\"out\" or \"in out\" required.\n");
break;
case colon_miss:
printf("Colon \":\" missing.\n");
break;
case dot_miss:
printf("Dot \".\" missing.\n");
break;
case id_not_declared:
printf("Identifier not declared.\n");
break;
case clsround_miss:
printf("Round bracket \")\" missing.\n");
break;
case opnround_miss:
printf("Round bracket \"(\" missing.\n");
break;
case package_miss:
printf("Keyword \"package\" missing.\n");
break;
case record_miss:
printf("Keyword \"record\" missing.\n");
break;
case return_miss:
printf("Keyword \"return\" missing.\n");
break;
case istok_miss:
printf("Keyword \"is\" missing.\n");
break;
case endtok_miss:
printf("Keyword \"end\" missing.\n");
break;
case type_miss:
printf("Keyword \"type\", \"procedure\" or \"function\" missing.\n");
break;
case char_ignored:
printf("Illegal character:\"%c\", ignored.\n", lastcar);
break;
case toomany_dig:
printf("Too many digits in this number.\n");
break;
case toomany_dim:
printf("Too many dimensions in this array.\n");
break;
case ident_reserved:
printf("Identifier reserved for compiler use.\n");
break;
case bad_name:
printf("Identifier does not match already declared package name.\n");
break;
case proc_exp:
printf("Keyword \"procedure\" or \"function\" expected.\n");
break;
case params_miss:
printf("Parameters missing.\n");
break;
case input_miss:
printf("Input file missing, can't go on.\n");
break;
case bad_input_name:
printf("Bad input file name: \".ext\" extension reserved.\n");
break;
case cant_opn_input:
printf("Can't open input file.\n");
break;
case cant_opn_ext:
printf("Can't open \".ext\" file.\n");
break;
case cant_opn_client:
printf("Can't open client file.\n");
break;
case cant_opn_server:
printf("Can't open server file.\n");
break;
case cant_cls_input:
printf("Can't close input file.\n");
break;
case cant_cls_client:
printf("Can't close client file.\n");
break;
case cant_cls_server:
printf("Can't close server file.\n");
break;
case cant_cls_ext:
printf("Can't close \".ext\" file.\n");
break;
case internal_error:
printf("Sorry - Unexpected internal condition in compiler.\n");
break;
case unexp_eof:
printf("Unexpected end of input file.\n");
break;
}/*End_CASE*/
} /*ERROR*/
/* Write a token name
------------------
*/
Static Void write_token(what)
type_token what;
{
if ((unsigned long)what > (int)nultok) {
printf("(Unknown token!)");
return;
}
switch (what) {
case chartok:
printf("RPC_CHAR");
break;
case bytetok:
printf("RPC_BYTE");
break;
case shortok:
printf("RPC_SHORT");
break;
case integertok:
printf("RPC_INTEGER");
break;
case real32tok:
printf("RPC_REAL32");
break;
case real48tok:
printf("RPC_REAL48");
break;
case real64tok:
printf("RPC_REAL64");
break;
case real128tok:
printf("RPC_REAL128");
break;
case longtok:
printf("RPC_LONG");
break;
case arraytok:
printf("ARRAY");
break;
case sequence:
printf("SEQUENCE");
break;
case stringtok:
printf("STRING");
break;
case substring:
printf("SUBSTRING");
break;
case package:
printf("PACKAGE");
break;
case semicolon:
printf("SEMICOLON");
break;
case typetok:
printf("TYPE");
break;
case endtok:
printf("END");
break;
case colon:
printf("colon \":\"");
break;
case comma:
printf("comma \",\"");
break;
case opnround:
printf("\"(\"");
break;
case clsround:
printf("\")\"");
break;
case oftok:
printf("OF");
break;
case intok:
printf("IN");
break;
case outok:
printf("OUT");
break;
case inoutok:
printf("INOUT");
break;
case istok:
printf("IS");
break;
case return_:
printf("RETURN");
break;
case dot:
printf("\".\"");
break;
case ident:
printf("identifier");
break;
case number:
printf("number");
break;
case proctok:
printf("PROCEDURE");
break;
case functok:
printf("FUNCTION ");
break;
case nultok:
printf("(Null Token!)");
break;
}
} /*write_token*/
/* Print last line read from declaration file
------------------------------------------
On entry:
'lastindex' is the index of the last token read.
*/
Static Void print_last_line()
{
long a, FORLIM;
printf("INPUT:");
FORLIM = inp_line.len;
for (a = 0; a < FORLIM; a++)
putchar(inp_line.str[a]);
putchar('\n');
FORLIM = lastindex + 4;
for (a = 1; a <= FORLIM; a++)
putchar('-');
printf("^\n");
}
Static Void linerror(which)
err_type which;
{
printf("RPCC: Error found on line %3ld:\n", lineread);
print_last_line();
error(which);
putchar('\n');
}
Static Void find_tok(kind)
long *kind;
{
/** writeln('RPCC: Skipping ...'); **/
while (!P_inset(token.kind, kind))
getoken();
/**
print_last_line;
writeln('RPCC: Restarting analysis here.');
writeln;
**/
}
Static Void errfind(which, kind)
err_type which;
long *kind;
{
linerror(which);
find_tok(kind);
}
Static Void abort_pgm(which)
err_type which;
{
error(which);
printf("Fatal error, program aborted.\n");
_Escape(0);
}
/** Debugging module **/
/********************************************************************
* Top-down RPC compiler - Debugging module
*
* Author:
* Antonio Pastore, Tec. Student 1986, DD/OC, CERN
*
* History:
* 28 May 1986 first written (AP)
* 27 Jun 1986 last update by AP
* 26 Aug 1987 bug fix in print_tab_types - Nici.
*
***********************************************************************/
Static Void debug_print_name(where, name)
FILE **where;
id_name name;
{
long i;
for (i = 0; i < name.len; i++)
putc(name.str[i], *where);
}
Static Void printok(what)
type_token what;
{
if ((unsigned long)what > (int)nultok) {
printf("?????? (bad type token) ???");
return;
}
switch (what) {
case chartok:
printf("RPC_CHAR");
break;
case bytetok:
printf("RPC_BYTE");
break;
case shortok:
printf("RPC_SHORT");
break;
case integertok:
printf("RPC_INTEGER");
break;
case real32tok:
printf("RPC_REAL32");
break;
case real48tok:
printf("RPC_REAL48");
break;
case real64tok:
printf("RPC_REAL64");
break;
case real128tok:
printf("RPC_REAL128");
break;
case longtok:
printf("RPC_LONG");
break;
case arraytok:
printf("ARRAY");
break;
case sequence:
printf("SEQUENCE");
break;
case stringtok:
printf("STRING");
break;
case substring:
printf("SUBSTRING");
break;
case package:
printf("PACKAGE");
break;
case semicolon:
printf("SEMICOLON");
break;
case typetok:
printf("TYPE");
break;
case endtok:
printf("END");
break;
case colon:
printf("COLON");
break;
case comma:
printf("COMMA");
break;
case opnround:
printf("OPNROUND");
break;
case clsround:
printf("CLSROUND");
break;
case oftok:
printf("OF");
break;
case intok:
printf("IN ");
break;
case outok:
printf("OUT ");
break;
case inoutok:
printf("IN OUT ");
break;
case istok:
printf("IS");
break;
case return_:
printf("RETURN");
break;
case dot:
printf("DOT");
break;
case ident:
printf("IDENT");
break;
case number:
printf("NUMBER");
break;
case proctok:
printf("PROCEDURE");
break;
case functok:
printf("FUNCTION ");
break;
case nultok:
printf("NULTOKEN");
break;
}
} /*PRINT*/
/*_____________________________________________________________________________
Print out a type definition
Prints out whole lines.
*/
/* indenting function */
Static long indent(level)
long level;
{
return (level * 4 + 16);
}
Static Void print_def_type(ptr, level)
defined_type *ptr;
long level;
{
named_type *scan;
FILE *TEMP;
named_type *WITH1;
if (ptr == NULL) {
printf("???? NIL pointer ????");
return;
}
if (((1L << ((long)ptr->typ_basic_type)) &
((1L << ((long)substring + 1)) - (1L << ((long)chartok)))) == 0) {
printf("???? Bad basic type ????");
return;
}
if ((level > 1 ||
((1L << ((long)ptr->typ_basic_type)) &
((1L << ((long)longtok + 1)) - (1L << ((long)chartok)))) != 0) &&
ptr->typ_name != NULL) {
/* p2c: rpcc.p, line 706: Note:
* Line breaker spent 2.2+3.13 seconds, 1526 tries on line 1024 [251] */
printf("%*c", (int)indent(level), ' ');
/* Use predefined name if possible */
TEMP = stdout;
/* p2c: rpcc.p, line 655:
* Note: Taking address of stdout; consider setting VarFiles = 0 [144] */
debug_print_name(&TEMP, ptr->typ_name->nty_name);
printf(";\n");
return;
}
switch (ptr->typ_basic_type) {
case chartok:
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok:
printf("%*c", (int)indent(level), ' ');
printok(ptr->typ_basic_type);
printf("; -- ??? unnamed basic type ???\n");
break;
case stringtok:
printf("%*cSTRING (%ld);\n",
(int)indent(level), ' ', ptr->UU.U12.typ_high);
break;
case arraytok:
printf("%*cARRAY (%ld..%ld) OF\n",
(int)indent(level), ' ', ptr->UU.U12.typ_low,
ptr->UU.U12.typ_high);
print_def_type(ptr->typ_subtype, level + 1);
break;
case accesstok:
printf("%*cACCESS\n", (int)indent(level), ' ');
print_def_type(ptr->typ_subtype, level + 1);
break;
case recordtok:
printf("%*cRECORD\n", (int)indent(level), ' ');
scan = ptr->UU.typ_fields;
while (scan != NULL) {
WITH1 = scan;
printf("%*c", (int)indent(level + 1), ' ');
TEMP = stdout;
/* p2c: rpcc.p, line 689:
* Note: Taking address of stdout; consider setting VarFiles = 0 [144] */
debug_print_name(&TEMP, WITH1->nty_name);
printf(": \n");
print_def_type(WITH1->nty_type, level + 2);
scan = scan->nty_next; /*while*/
}
printf("%*cEND RECORD;\n", (int)indent(level), ' ');
break;
case sequence:
printf("%*cSEQUENCE (%ld) OF \n",
(int)indent(level), ' ', ptr->UU.U12.typ_high);
print_def_type(ptr->typ_subtype, level + 1);
break;
case substring:
printf("%*cSUBSTRING (%ld);\n",
(int)indent(level), ' ', ptr->UU.U12.typ_high);
break;
}/*end_case*/
} /*PRINT_DEF_TYPE*/
Static Void print_tab_types()
{
/****
* This procedure prints on standard output the tree of the type's declaration.
****/
named_type *scan;
options a;
FILE *TEMP;
defined_type *WITH;
printf("\n-- Compiler options requested:\n\n");
for (a = ccerncross; (long)a <= (long)invalid; a = (options)((long)a + 1)) {
if (runoptions[(long)a - (long)ccerncross].value)
printf("-- Option %.10s is set.\n",
runoptions[(long)a - (long)ccerncross].name);
}
printf("\n\n-- Tree of types (alphabetical order)\n\n");
scan = typeptr;
while (scan != NULL) {
printf("TYPE ");
TEMP = stdout;
/* p2c: rpcc.p, line 731:
* Note: Taking address of stdout; consider setting VarFiles = 0 [144] */
debug_print_name(&TEMP, scan->nty_name);
printf(" IS \n");
print_def_type(scan->nty_type, 1L);
WITH = scan->nty_type;
if (WITH->typ_max_size == WITH->typ_min_size)
printf(" -- Representation: %ld bytes.\n", WITH->typ_max_size);
else
printf(" -- Representation: %ld bytes minimum, %ld bytes maximum.\n",
WITH->typ_min_size, WITH->typ_max_size);
/* p2c: rpcc.p, line 743:
* Note: Line breaker spent 1.1 seconds, 4 tries on line 1133 [251] */
putchar('\n');
scan = scan->nty_next;
} /*end_while*/
} /*PRINT_TAB_TYPES*/
Local Void print_list(ptr)
id_list *ptr;
{
printf("with parameters:\n");
do {
printf(" %.*s : ", MAXIDLEN, ptr->name.str);
printok(ptr->attr);
if (ptr->id_type->typ_name != NULL)
printf("%.*s", MAXIDLEN, ptr->id_type->typ_name->nty_name.str);
else
print_def_type(ptr->id_type, 1L);
putchar('\n');
ptr = ptr->next;
} while (ptr != NULL);
printf("(end of parameters)");
}
Static Void print_tab_blocks()
{
/****
* This procedure prints on standard output the tree of the block's declaration.
****/
block_table *scan;
printf("\n################## TREE OF BLOCKS #######################\n\n");
printf("PACKAGE %.*s IS\n", MAXIDLEN, unitname.str);
scan = blockptr;
while (scan != NULL) {
putchar('\n');
printok(scan->b_type);
printf(" %.*s", MAXIDLEN, scan->name.str);
if (scan->list != NULL)
print_list(scan->list);
if (scan->b_type == functok) {
printf(" RETURN ");
printok(scan->return_);
}
printf("\n-- Minimum %ld bytes in, %ld out.\n",
scan->blk_min_in, scan->blk_min_out);
printf("-- Maximum %ld bytes in, %ld out.\n",
scan->blk_max_in, scan->blk_max_out);
printf("-- _______________________________________________________\n");
scan = scan->next;
} /*end_while*/
printf("END %.*s;\n\n", MAXIDLEN, unitname.str);
}
Static Void print_token()
{
printf(" Token read: ");
if (token.kind == ident)
printf("IDENT:\"%.*s\"", MAXIDLEN, token.UU.name.str);
else {
if (token.kind == number)
printf("NUMBER: %12ld", token.UU.value);
else
printok(token.kind);
}
putchar('\n');
} /*PRINT_TOKEN*/
Local Void put_keyword(name, tok)
Char *name;
type_token tok;
{
maxkeyword++;
memcpy(keyword[maxkeyword - 1].name, name, sizeof(char_name));
keyword[maxkeyword - 1].symbol = tok;
}
/** Global initialization **/
/********************************************************************
* Top-down RPC compiler - Initialization code
*
* Author:
* Antonio Pastore, Tec. Student 1986, DD/OC, CERN
*
History:
28 May 86 Written, Antonio Pastore, Technical student, DD/OC
11 Jul 86 Last update by antonio
2 Nov 86 Extra options added (TBL)
10 Aug 87 genericC options added; structural changes - Nici.
17 Aug 87 byvalue option added - Nici.
26 Aug 87 Options timeout and version added - Nici.
1 Sep 87 Options types and <s,c>pcturbo added - Nici.
26 Aug 88 Options <s,c>macturbo added. Roberto Bagnara, DD/OC
23 Oct 88 RECORD and ACCESS added - Tim BL
1 Nov 88 PILS output options added (Louis Tremblet)
***********************************************************************/
Static Void getoken_init()
{
/** Vars in getoken **/
inp_line.len = 0;
inp_line.start = 0;
lastindex = 1;
lineread = 0;
tok_present = false;
lastcar = ' ';
char_ready = false;
incomment = false;
/** The following MUST be in alphabetical order !!! **/
maxkeyword = 0;
put_keyword("access ", accesstok);
put_keyword("array ", arraytok);
put_keyword("end ", endtok);
put_keyword("function ", functok);
put_keyword("in ", intok);
put_keyword("inout ", inoutok);
put_keyword("is ", istok);
put_keyword("of ", oftok);
put_keyword("out ", outok);
put_keyword("package ", package);
put_keyword("pragma ", pragmatok);
put_keyword("procedure ", proctok);
put_keyword("record ", recordtok);
put_keyword("return ", return_);
put_keyword("rpc_byte ", bytetok);
put_keyword("rpc_char ", chartok);
put_keyword("rpc_integer ", integertok);
put_keyword("rpc_long ", longtok);
put_keyword("rpc_real128 ", real128tok);
put_keyword("rpc_real32 ", real32tok);
put_keyword("rpc_real48 ", real48tok);
put_keyword("rpc_real64 ", real64tok);
put_keyword("rpc_short ", shortok);
put_keyword("sequence ", sequence);
put_keyword("string ", stringtok);
put_keyword("substring ", substring);
put_keyword("type ", typetok);
memcpy(upkpck[0], "upk", 3L); /* Part of output of code generator */
memcpy(upkpck[true], "pck", 3L);
}
Static Void inp_options()
{
options opt;
for (opt = ccerncross; (long)opt <= (long)invalid; opt = (options)((long)opt + 1))
runoptions[(long)opt - (long)ccerncross].value = false;
memcpy(runoptions[(long)cmonolith - (long)ccerncross].name, "cmonolith ",
sizeof(opt_name));
memcpy(runoptions[0].name, "ccerncross", sizeof(opt_name));
memcpy(runoptions[(long)cm6809 - (long)ccerncross].name, "cm6809 ",
sizeof(opt_name));
memcpy(runoptions[(long)cvaxvms - (long)ccerncross].name, "cvaxvms ",
sizeof(opt_name));
memcpy(runoptions[(long)cvaxpas - (long)ccerncross].name, "cvaxpas ",
sizeof(opt_name));
memcpy(runoptions[(long)cunixbsd - (long)ccerncross].name, "cunixbsd ",
sizeof(opt_name));
memcpy(runoptions[(long)cpcturbo - (long)ccerncross].name, "cpcturbo ",
sizeof(opt_name));
memcpy(runoptions[(long)cmacturbo - (long)ccerncross].name, "cmacturbo ",
sizeof(opt_name));
memcpy(runoptions[(long)cpils - (long)ccerncross].name, "cpils ",
sizeof(opt_name));
memcpy(runoptions[(long)cvaxfor - (long)ccerncross].name, "cfortran ",
sizeof(opt_name));
memcpy(runoptions[(long)cgenericc - (long)ccerncross].name, "cgenericc ",
sizeof(opt_name));
memcpy(runoptions[(long)smonolith - (long)ccerncross].name, "smonolith ",
sizeof(opt_name));
memcpy(runoptions[(long)scerncross - (long)ccerncross].name, "scerncross",
sizeof(opt_name));
memcpy(runoptions[(long)sm6809 - (long)ccerncross].name, "sm6809 ",
sizeof(opt_name));
memcpy(runoptions[(long)svaxvms - (long)ccerncross].name, "svaxvms ",
sizeof(opt_name));
memcpy(runoptions[(long)svaxpas - (long)ccerncross].name, "svaxpas ",
sizeof(opt_name));
memcpy(runoptions[(long)sunixbsd - (long)ccerncross].name, "sunixbsd ",
sizeof(opt_name));
memcpy(runoptions[(long)spcturbo - (long)ccerncross].name, "spcturbo ",
sizeof(opt_name));
memcpy(runoptions[(long)smacturbo - (long)ccerncross].name, "smacturbo ",
sizeof(opt_name));
memcpy(runoptions[(long)spils - (long)ccerncross].name, "spils ",
sizeof(opt_name));
memcpy(runoptions[(long)svaxfor - (long)ccerncross].name, "sfortran ",
sizeof(opt_name));
memcpy(runoptions[(long)sgenericc - (long)ccerncross].name, "sgenericc ",
sizeof(opt_name));
memcpy(runoptions[(long)dlex - (long)ccerncross].name, "dlex ",
sizeof(opt_name));
memcpy(runoptions[(long)dlexhot - (long)ccerncross].name, "dlexhot ",
sizeof(opt_name));
memcpy(runoptions[(long)dtree - (long)ccerncross].name, "dtree ",
sizeof(opt_name));
memcpy(runoptions[(long)shortint - (long)ccerncross].name, "shortint ",
sizeof(opt_name));
memcpy(runoptions[(long)stdescr - (long)ccerncross].name, "stdescr ",
sizeof(opt_name));
memcpy(runoptions[(long)concurrent - (long)ccerncross].name, "concurrent",
sizeof(opt_name));
memcpy(runoptions[(long)noautoinit - (long)ccerncross].name, "noautoinit",
sizeof(opt_name));
memcpy(runoptions[(long)byvalue - (long)ccerncross].name, "byvalue ",
sizeof(opt_name));
memcpy(runoptions[(long)timeout - (long)ccerncross].name, "timeout ",
sizeof(opt_name));
memcpy(runoptions[(long)version - (long)ccerncross].name, "version ",
sizeof(opt_name));
memcpy(runoptions[(long)types - (long)ccerncross].name, "types ",
sizeof(opt_name));
Cmode = 1L << ((long)genericc);
ser_name.len = 0;
ser_mode = cerncross;
ser_spec = false;
cli_name.len = 0;
cli_mode = cerncross;
cli_spec = false;
checksum = 0;
ch_there = ' ';
is_blank = true;
}
Static Void pointers_init()
{
typeptr = NULL;
blockptr = NULL;
}
Static Void init_global()
{
getoken_init();
inp_options();
pointers_init();
errorfound = 0;
}
/** Input parameters management **/
/********************************************************************
* Top-down RPC compiler - Parameters management
*
* Author:
* Antonio Pastore, Tec. Student 1986, DD/OC, CERN
*
28 May 1986 Written (Antonio)
27 Jun 1986 Last update by Antonio
12 Feb 87 No longer overwrites existing files: makes new version
10 Aug 87 get_argv (UNIXBSD): string length bug fixed;
options "[s,c]<mode>=<filename>" implemented;
bug fix: disallow problematic MAGIC characters;
catch multiple server/client specifications - Nici.
26 Aug 87 Options timeout and version added - Nici.
20 Mar 88 For loop vaiable was used after loop in Unix file open
Subsctring function now used in VMS file open.
15 Dec 88 Bug fix: filename with 10 char long option was ignored
***********************************************************************/
/* M A C H I N E D E P E N D A N T R O U T I N E S
============= ================= ===============
These are:
get_argc(count) Return number of arguments
get_argv(index, str, len) Return one argument as a string
file_open(file, name, mode) Open a file
file-close(file) Close a file
*/
Static Void get_argc(count)
long *count;
{
*count = P_argc - 1; /** Predefined identifier **/
}
Static Void get_argv(what, towhere, len)
long what;
Char *towhere;
long *len;
{
boolean loop;
P_sun_argv(towhere, sizeof(longstring), (int)what);
/**
* Remember:
* command line parameters are truncated or padded with blanks!!
**/
*len = 0;
loop = true;
while (loop && *len <= MAXSTRING) {
if (towhere[*len] != ' ')
(*len)++;
else
loop = false;
}
}
Static boolean file_open(file_des, name, mode)
FILE **file_des;
astring *name;
open_mode mode;
{
/***
* Try to open a file with 'name' name, returns true if succesful,
* false otherwise.
***/
long a;
longstring str;
long FORLIM;
Char STR1[256];
FORLIM = name->len;
for (a = 0; a < FORLIM; a++)
str[a] = name->str[a];
a = name->len; /* 80320 */
if (a < MAXSTRING)
a++;
str[a - 1] = '\0';
if (mode == rewriting) {
if (*file_des != NULL) {
sprintf(STR1, "%.*s", MAXSTRING, str);
*file_des = freopen(STR1, "w", *file_des);
} else {
sprintf(STR1, "%.*s", MAXSTRING, str);
*file_des = fopen(STR1, "w");
}
if (*file_des == NULL)
_EscIO(FileNotFound);
return true;
}
if (*file_des != NULL) {
sprintf(STR1, "%.*s", MAXSTRING, str);
*file_des = freopen(STR1, "r", *file_des);
} else {
sprintf(STR1, "%.*s", MAXSTRING, str);
*file_des = fopen(STR1, "r");
}
if (*file_des == NULL)
_EscIO(FileNotFound);
return true;
}
Static boolean file_close(file_des)
FILE **file_des;
{
fflush(*file_des);
P_ioresult = 0;
return true;
}
#define MAGIC1 "-"
/* ugly! This disallows magic charcter '-' for */
#define MAGIC2 "-"
/* E N D O F M A C H I N E D E P E N D A N T B I T
******************************************************************************
*/
/* Analize an option:
-----------------
If interactive skip MAGIC and don't set input file name.
The spelling of the name of this procedure is historical.
*/
Static Void analize(arg, len, interactive)
Char *arg;
long len;
boolean interactive;
{
opt_name loc_arg;
long a, i;
boolean found;
options scan;
boolean present; /* Parameter present */
Char STR1[256], STR2[256];
long FORLIM;
sprintf(STR1, "%c", arg[0]);
sprintf(STR2, "%c", arg[0]);
/* Options are at most 10 characters long, but may be followed by an '='
sign which must be scanned and may be in position 11.
*/
if (((strcmp(STR1, MAGIC1) == 0) | (strcmp(STR2, MAGIC2) == 0)) ||
interactive)
/** Options **/
{ /** Option **/
memcpy(loc_arg, " ", sizeof(opt_name));
a = 1;
present = false;
while (a <= 11 && a < len && !present) {
if (arg[a] == '=')
present = true;
else if (a <= 10) {
if (isupper(arg[a]))
loc_arg[a - 1] = _tolower(arg[a]);
else
loc_arg[a - 1] = arg[a];
}
a++;
}
/** Find options **/
scan = ccerncross;
found = false;
/** if present then a := a + 1; skip over "=" out 90926 **/
do {
if (!strncmp(loc_arg, runoptions[(long)scan - (long)ccerncross].name,
sizeof(opt_name))) {
found = true;
if ((int)scan < NUMOMODES) { /*client specification*/
if (cli_spec) {
printf("RPCC: ");
for (a = 0; a < len; a++)
putchar(arg[a]);
printf(": client already specified - option ignored.\n");
} else {
cli_spec = true;
for (i = 1; i <= (int)scan; i++)
cli_mode = (output_mode)((long)cli_mode + 1);
if (present) {
cli_name.len = len - a;
FORLIM = len - a;
for (i = 0; i < FORLIM; i++)
cli_name.str[i] = arg[a + i];
}
}
} else if ((int)scan < NUMOMODES * 2) {
if (ser_spec) {
printf("RPCC: ");
for (a = 0; a < len; a++)
putchar(arg[a]);
printf(": server already specified - option ignored.\n");
} else {
ser_spec = true;
for (i = 1; i <= (int)scan - NUMOMODES; i++)
ser_mode = (output_mode)((long)ser_mode + 1);
if (present) {
ser_name.len = len - a;
FORLIM = len - a;
for (i = 0; i < FORLIM; i++)
ser_name.str[i] = arg[a + i];
}
}
} else {
runoptions[(long)scan - (long)ccerncross].value = true;
if (scan == timeout) {
if (a >= len) {
printf("RPCC: timeout value missing, default will be used.\n");
runoptions[(long)timeout - (long)ccerncross].value = false;
} else {
timeout_val = 0;
FORLIM = len - a;
for (i = 0; i < FORLIM; i++) {
if (isdigit(arg[a + i]))
timeout_val = timeout_val * 10 + arg[a + i] - '0';
else {
printf("RPCC timeout option: ");
abort_pgm(number_req);
}
}
if (timeout_val == 0)
printf("RPCC: timeout is zero, hope that's okay.\n");
}
} else if (scan == version) {
if (a >= len) {
printf("RPCC: supplying missing version number.\n");
runoptions[(long)version - (long)ccerncross].value = false;
} else {
version_num = 0;
FORLIM = len - a;
for (i = 0; i < FORLIM; i++) {
if (isdigit(arg[a + i]))
version_num = version_num * 10 + arg[a + i] - '0';
else {
printf("RPCC version option: ");
abort_pgm(number_req);
}
}
if (version_num == 0)
printf("RPCC: stub version check disabled.\n");
}
}
}
} else
scan = (options)((long)scan + 1);
} while (!(found || scan == invalid));
if (scan != invalid)
return;
printf("RPCC: ");
for (a = 0; a < len; a++)
putchar(arg[a]);
printf(": unrecognized option, ignored.\n");
return;
}
inp_name.len = len;
for (a = 0; a < len; a++)
inp_name.str[a] = arg[a];
/*server specification*/
/*a REAL option*/
/** File name **/
} /*ANALIZE*/
#undef MAGIC1
#undef MAGIC2
/* Make a filename out of the input file name and a prefix
-------------------------------------------------------
The prefix is put on the front of the name part of the filename.
This is taken to be the last bit which contains only alphanumerics and
dots and underscores. Other characters are assumed to be directory
information, which must be left intact.
*/
Static Void make_filename(filename, prefix)
astring *filename;
Char *prefix;
{
long i, rdp; /* read pointer */
boolean done;
long FORLIM;
rdp = inp_name.len; /* point to last char */
done = false; /* Find start of name - a horrible Pascal loop */
do { /* Oh, to be programming in C at this point! */
if (rdp >= 1) {
if (inp_name.str[rdp - 1] == '_' || inp_name.str[rdp - 1] == '.' ||
isalnum(inp_name.str[rdp - 1]))
rdp--;
else
done = true;
} else
done = true;
} while (!done);
/* rdp is the number of characters of directory etc preceding the filename*/
filename->len = 0;
for (i = 0; i < rdp; i++) {
filename->len++;
filename->str[filename->len - 1] = inp_name.str[i];
}
for (i = 0; i <= 2; i++) {
filename->len++;
filename->str[filename->len - 1] = prefix[i];
}
FORLIM = inp_name.len;
for (i = rdp; i < FORLIM; i++) {
filename->len++;
filename->str[filename->len - 1] = inp_name.str[i];
}
}
Static Void get_parameters()
{
/*****
* On entry: parameters on the command line
* On exit:
* 'inp_name' filled with input file name;
* 'inp_file' opened using 'inp_name' name;
* 'cli_name' filled with client file name; ('cli'+inp_name)
* 'ser_name' filled with server file name; ('ser'+inp_name)
* 'ext_name' filled with the external file name; (inp_name.'ext')
*******/
long a, b, count, p_argc, p_len;
longstring p_argv;
Char ext[3]; /* TBL 14-8-86 */
inp_name.len = 0;
if (COMMANDLINE) {
count = 1;
get_argc(&p_argc);
while (count <= p_argc) {
get_argv(count, p_argv, &p_len);
count++;
/** Analize option **/
analize(p_argv, p_len, false);
} /*end_while*/
} else {
printf("Input file name: ");
inp_name.len = 0;
while (!P_eoln(stdin) && inp_name.len <= MAXSTRING) {
inp_name.len++;
inp_name.str[inp_name.len - 1] = getchar();
if (inp_name.str[inp_name.len - 1] == '\n')
inp_name.str[inp_name.len - 1] = ' ';
}
/** Skip end of line **/
scanf("%*[^\n]");
getchar();
/** Get options **/
do {
printf("Debugging options: ");
count = 1;
while (!P_eoln(stdin) && count < MAXSTRING) {
count++;
p_argv[count - 1] = getchar();
if (p_argv[count - 1] == '\n')
p_argv[count - 1] = ' ';
}
scanf("%*[^\n]");
getchar();
/** Analize option **/
if (count > 1)
analize(p_argv, count, true);
} while (count != 1);
}
if (inp_name.len == 0) {
printf("RPCC: usage: source_file [options]\n");
abort_pgm(input_miss);
}
/** Try to open input file **/
if (!file_open(&inp_file, &inp_name, resetting))
abort_pgm(cant_opn_input);
/** Build client, server and external default file names **/
if (cli_name.len == 0)
make_filename(&cli_name, "cli");
if (ser_name.len == 0)
make_filename(&ser_name, "ser");
/* Make the external declaration file name:
Th extension is changed to '.ext'
*/
b = inp_name.len;
while (b >= 1 && isalpha(inp_name.str[b - 1])) /*then*/
b--;
if (b == 0) /* No '.' found */
b = inp_name.len;
if (inp_name.str[b - 1] != '.') /* Found directory */
b = inp_name.len;
for (a = 0; a < b; a++) {
if (a + 1 <= MAXSTRING - 3)
ext_name.str[a] = inp_name.str[a];
}
if (b <= inp_name.len - 3) { /* extension was specified */
ext[0] = inp_name.str[b];
ext[1] = inp_name.str[b + 1];
ext[2] = inp_name.str[b + 2];
if (!strncmp(ext, "ext", 3) || !strncmp(ext, "EXT", 3))
abort_pgm(bad_input_name);
} else { /*if*/
b++; /* Add a '.' if it wasn't */
ext_name.str[b - 1] = '.';
}
ext_name.str[b] = 'e';
ext_name.str[b + 1] = 'x';
ext_name.str[b + 2] = 't';
ext_name.len = b + 3;
/** Get file name **/
} /*GET_PARAMETERS*/
#define TAB 9 /** ASCII TAB character **/
/***
* Note: 'lastcar' is declared global to be printed in error messages.
***/
Local Char AP_getchar()
{
/** renamed - Nici, 26 Aug 87 **/
Char Result;
long a;
Char localcar;
long FORLIM;
if (char_ready) {
Result = oldchar;
char_ready = false;
return Result;
}
while (inp_line.start > inp_line.len || inp_line.len == 0) {
inp_line.len = 0;
inp_line.start = 1;
lastindex = 1;
if (P_eof(inp_file)) {
abort_pgm(unexp_eof);
continue;
}
while (!P_eoln(inp_file)) {
inp_line.len++;
inp_line.str[inp_line.len - 1] = getc(inp_file);
if (inp_line.str[inp_line.len - 1] == '\n')
inp_line.str[inp_line.len - 1] = ' ';
if (inp_line.str[inp_line.len - 1] == TAB)
inp_line.str[inp_line.len - 1] = ' '; /** Convert TAB to space **/
else {
if (inp_line.str[inp_line.len - 1] < 32)
inp_line.len--;
}
}
inp_line.len++;
inp_line.str[inp_line.len - 1] = ' ';
fscanf(inp_file, "%*[^\n]"); /** Skip END_OF_LINE **/
getc(inp_file);
lineread++; /** Line counter **/
if (runoptions[(long)dlex - (long)ccerncross].value) {
printf("LINE READ: ");
FORLIM = inp_line.len;
for (a = 0; a < FORLIM; a++)
putchar(inp_line.str[a]);
putchar('\n');
}
}
localcar = inp_line.str[inp_line.start - 1];
inp_line.start++; /*END_WITH*/
/** Make it lower **/
if (isupper(localcar))
localcar = _tolower(localcar);
Result = localcar;
/** Skip comment if any **/
if (localcar != '-' || incomment)
return Result;
incomment = true;
oldchar = AP_getchar();
incomment = false;
if (oldchar == '-') {
inp_line.len = 0; /** Force the reading of a new line **/
return ' '; /** Return space **/
}
Result = localcar;
char_ready = true;
return Result;
/*END_ELSE char_ready*/
} /*AP_GETCHAR*/
#undef TAB
Local Char getchar_()
{
/** written - Nici, 26 Aug 87 **/
/** This rather complex interface ensures that blanks are skipped **/
/** whenever they are not syntactically relevant, in order to make **/
/** the checksum of syntactically identical RPCL files invariant. **/
Char ch;
if (ch_there != ' ') {
ch = ch_there;
ch_there = ' ';
} else {
ch = AP_getchar();
if (ch == ' ') {
if (!P_eof(inp_file)) {
do {
ch = AP_getchar();
} while (ch == ' ');
}
if (!(ch == ';' || ch == ',' || ch == ')' || ch == '(' || ch == ':' ||
is_blank)) {
ch_there = ch;
ch = ' ';
}
}
}
is_blank = (ch == ';' || ch == ',' || ch == ')' || ch == '(' || ch == ':' ||
ch == ' ');
checksum = (checksum * 3 + ch - ' ') % 8999;
/* p2c: rpcc.p, line 1476:
* Note: Using % for possibly-negative arguments [317] */
if (!runoptions[(long)dlexhot - (long)ccerncross].value)
return ch;
if (ch == ' ')
printf("%c\n", ch);
else
putchar(ch);
return ch;
}
/** Getoken, lexical analizer **/
/********************************************************************
* Top-down RPC compiler - Lexical analizer
*
* Author:
* Antonio Pastore, Tec. Student 1986, DD/OC, CERN
*
* History:
* 28 May 1986 first written (AP)
* 27 Jun 1986 last update by AP
* 26 Aug 1987 checksum (for version) included - Nici.
* 16 Nov 1988 Bug fix: crashed with 26 char identifier (TBL)
*
***********************************************************************/
/*GETOKEN returns in TOKEN (globally declared) the last token read*/
Static Void getoken()
{
long i, j, k, sign;
/*
_____________________________________________________________________________
*/
if (tok_present) {
token = lastoken;
tok_present = false;
} else {
do { /** Find a valid token **/
if (lastcar == ' ') /** Skip blank **/
lastcar = getchar_();
lastindex = inp_line.start; /** To print error messages **/
/** Check if identifier or keyword **/
if (lastcar == '_' || islower(lastcar)) {
/** Suppose to be an identifier or keyword **/
token.kind = ident;
token.UU.name.len = 0;
do {
if (token.UU.name.len < MAXIDLEN) { /* was <= 81116 TBL */
token.UU.name.len++;
token.UU.name.str[token.UU.name.len - 1] = lastcar;
}
lastcar = getchar_();
} while (lastcar == '_' || islower(lastcar) || isdigit(lastcar));
/** Fill with blanks **/
for (i = token.UU.name.len; i < MAXIDLEN; i++)
token.UU.name.str[i] = ' ';
/** Try to see if keyword **/
/** The following is the famous binary search!!! **/
i = 1;
j = maxkeyword;
do {
k = (i + j) / 2;
if (strncmp(token.UU.name.str, keyword[k - 1].name,
sizeof(char_name)) <= 0)
j = k - 1;
if (strncmp(token.UU.name.str, keyword[k - 1].name,
sizeof(char_name)) >= 0)
i = k + 1;
} while (i <= j);
if (i - 1 > j)
token.kind = keyword[k - 1].symbol;
else {
/** Check if illegal identifier, reserved for compiler use **/
if ((token.UU.name.str[0] == 'r' && token.UU.name.str[1] == 'p' &&
token.UU.name.str[2] == 'c' && token.UU.name.str[3] == '_') ||
!strncmp(token.UU.name.str, "b ",
sizeof(char_name)) ||
!strncmp(token.UU.name.str, "header ",
sizeof(char_name)) ||
!strncmp(token.UU.name.str, "ret ",
sizeof(char_name)))
/* p2c: rpcc.p, line 1583: Note:
* Line breaker spent 5.3+2.40 seconds, 2464 tries on line 2041 [251] */
linerror(ident_reserved);
token.kind = ident;
}
} /*identifier or keyword*/
else {
/** Check if number **/
if (lastcar == '-' || isdigit(lastcar)) { /*if number*/
token.kind = number;
token.UU.value = 0;
if (lastcar == '-') {
sign = -1;
lastcar = getchar_();
} else
sign = 1;
do {
if (token.UU.value < LONG_MAX / 10 - lastcar + '0')
token.UU.value = token.UU.value * 10 + lastcar - '0';
else {
error(toomany_dig);
token.UU.value = LONG_MAX;
}
lastcar = getchar_();
} while (isdigit(lastcar));
token.UU.value *= sign;
} else { /*if*/
/** Then should be one of these symbols! **/
if (lastcar != '.' && lastcar != ')' && lastcar != '(' &&
lastcar != ',' && lastcar != '=' && lastcar != ';' &&
lastcar != ':') {
token.kind = nultok;
error(char_ignored); /** Ignore this character **/
} else {
switch (lastcar) {
case ':':
token.kind = colon;
break;
case ';':
token.kind = semicolon;
break;
case ',':
token.kind = comma;
break;
case '(':
token.kind = opnround;
break;
case ')':
token.kind = clsround;
break;
case '.':
token.kind = dot;
break;
}/*end case*/
} /*if*/
lastcar = getchar_(); /** Read next char **/
}
}
} while (token.kind == nultok);
/*END_WITH*/
} /*end_token already present*/
if (runoptions[(long)dlex - (long)ccerncross].value)
print_token();
} /*getoken*/
/*
_____________________________________________________________________________
*/
Static Void backtoken()
{
/****
* This procedure save the value of 'tok' and uses it when next 'getoken' is
* called.
*****/
lastoken = token;
tok_present = true;
}
/** Parser **/
/* Top-down RPC compiler 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
---------------------------------------
*/
Static boolean expected(what, skip_until)
type_token what;
long *skip_until;
{
boolean Result;
getoken();
if (token.kind == what)
return true;
Result = false;
printf("RPCC: Error: Found ");
write_token(token.kind);
printf(" where ");
write_token(what);
printf(" was expected on line %ld:\n", lineread);
print_last_line();
putchar('\n');
find_tok(skip_until);
return Result;
/*if*/
}
/*_______________________________________________________________________________
Expression handling 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:
-------------------------------------
*/
Static Void append_1(expr, ch)
expression *expr;
Char ch;
{
expr->len++;
expr->str[expr->len - 1] = ch;
}
/* p2c: rpcc.p, line 1661: Warning: Unrecognized character in file [247] */
/* 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.
*/
Static Void format(final, template)
expression *final;
Char *template;
{
/*
On entry,
template must not be blank.
On exit,
expression copied from template with original expression inserted
in place of "$" signs.
*/
expression initial;
long e; /* effective end of template string*/
long i, j; /* loop index */
/*format*/
initial = *final;
final->len = 0;
e = template_length;
while (template[e - 1] == ' ') /* strip spaces */
e--;
for (i = 0; i < e; i++) { /*for*/
if (template[i] == '$') {
for (j = 0; j < initial.len; j++)
append_1(final, initial.str[j]);
} else
append_1(final, template[i]);
}
}
/* Put one character on the front of an expression prepend_1
-----------------------------------------------
*/
Static Void prepend_1(expr, ch)
expression *expr;
Char ch;
{
long a;
for (a = expr->len; a >= 1; a--)
expr->str[a] = expr->str[a - 1];
expr->str[0] = ch;
expr->len++;
}
/* Append an identifier to an expression append_name
-------------------------------------
*/
Static Void append_name(expr, name)
expression *expr;
id_name name;
{
long a;
for (a = 0; a < name.len; a++)
append_1(expr, name.str[a]);
}
/* p2c: rpcc.p, line 1717: Warning: Unrecognized character in file [247] */
/* 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.
*/
Static Void append_index(expr, level)
expression *expr;
long level;
{
format(expr, "$[rpc_ ");
append_1(expr, (Char)(level + 96));
append_1(expr, ']');
}
/* Append a decimal number to an expression append_decimal
----------------------------------------
*/
Static Void append_decimal(expr, x)
expression *expr;
long x;
{
long t, weight;
if (x < 0) {
append_1(expr, '-');
t = -x;
} else
t = x;
weight = 1; /* these are array bounds */
while (weight * 10 <= t)
weight *= 10;
/* weight is largest power of 10 not greater than t */
while (weight > 0) { /*while*/
append_1(expr, (Char)(t / weight + '0'));
t %= weight;
/* p2c: rpcc.p, line 1750:
* Note: Using % for possibly-negative arguments [317] */
weight /= 10;
}
}
/* p2c: rpcc.p, line 1754: Warning: Unrecognized character in file [247] */
/* 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.
*/
Static boolean find_type(head, name, father, son)
named_type *head;
id_name *name;
named_type **father, **son;
{
/* head of list*/
boolean found;
found = false;
*son = head; /** Head of the list **/
*father = *son;
while (*son != NULL && !found) {
if (!strncmp((*son)->nty_name.str, name->str, sizeof(char_name)))
found = true;
else {
*father = *son;
*son = (*son)->nty_next;
}
}
return found;
}
/* p2c: rpcc.p, line 1802: Warning: Unrecognized character in file [247] */
/* 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.
*/
Static Void insert_named_type(ptr, head)
named_type *ptr, **head;
{
named_type *son, *father;
/*insert_named_type*/
if (find_type(*head, &ptr->nty_name, &father, &son)) {
linerror(twice_declared); /** Identifier already declared **/
return;
}
if (*head == NULL) { /** List empty **/
*head = ptr;
ptr->nty_next = NULL;
return;
}
if (*head == son) { /** Insert ahead **/
*head = ptr;
ptr->nty_next = son;
} else {
father->nty_next = ptr;
ptr->nty_next = son;
}
}
/* p2c: rpcc.p, line 1835: Warning: Unrecognized character in file [247] */
/* 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.
*/
Static boolean find_block(name, father, son)
id_name *name;
block_table **father, **son;
{
boolean found;
found = false;
*son = blockptr; /** Head of the list **/
*father = *son;
while (*son != NULL && !found) { /*while*/
if (!strncmp((*son)->name.str, name->str, sizeof(char_name)))
found = true;
else {
*father = *son;
*son = (*son)->next;
}
}
return found;
}
/* Find parameter find_param
--------------
On exit,
son pointer to param if found, else NIL
return value TRUE if found else FALSE
*/
Static boolean find_param(name, head, son)
id_name *name;
id_list *head, **son;
{
boolean found;
*son = head;
found = false;
while (*son != NULL && !found) { /*while*/
if (!strncmp((*son)->name.str, name->str, sizeof(char_name)))
found = true;
else
*son = (*son)->next;
}
return found;
}
/* p2c: rpcc.p, line 1887: Warning: Unrecognized character in file [247] */
/* 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.
*/
Static Void ensure_type_named(pt)
defined_type *pt;
{
long i; /* String index */
expression expr; /* for building up the variable name */
named_type *pnt; /* Pointer to the new named type if any */
if (pt == NULL)
return;
if (pt->typ_name != NULL) /*if with if*/
return;
pnt = (named_type *)Malloc(sizeof(named_type));
format(&expr, "rpc_stype_");
append_decimal(&expr, number_of_invented_types);
number_of_invented_types++;
for (i = 0; i < expr.len; i++)
pnt->nty_name.str[i] = expr.str[i];
pnt->nty_name.len = expr.len;
pnt->nty_type = pt; /* Link name to type */
pt->typ_name = pnt; /* Link type to name */
insert_named_type(pnt, &typeptr); /* Put into the type list */
/*with*/
}
/* p2c: rpcc.p, line 1930: Warning: Unrecognized character in file [247] */
/* p2c: rpcc.p, line 1982: Warning: Unrecognized character in file [247] */
Static defined_type *parse_type PV();
/* p2c: rpcc.p, line 2069: Warning: Unrecognized character in file [247] */
/* Parse: ( <positive integer> ) get_size
-----
Error recovery:
If error found we suppose token forgotten so we 'backtoken'.
*/
Local Void get_size(pt)
defined_type *pt;
{
long SET[3];
getoken();
if (token.kind != opnround)
linerror(opnround_miss);
else
getoken();
pt->UU.U12.typ_low = 1; /* implied lower bound */
if (token.kind != number) {
linerror(number_req); /** Assume zero **/
pt->UU.U12.typ_high = 0;
} else {
pt->UU.U12.typ_high = token.UU.value;
getoken();
}
if (token.kind != clsround) {
errfind(clsround_miss,
P_expset(SET, (1L << ((long)oftok)) | (1L << ((long)semicolon))));
/* p2c: rpcc.p, line 2223:
* Note: Line breaker spent 4.6 seconds, 106 tries on line 2543 [251] */
backtoken();
}
if (pt->UU.U12.typ_high < 0) /*with*/
linerror(positive_req);
} /*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.
*/
Local defined_type *parse_subarray()
{
defined_type *pt;
long SET[3];
pt = (defined_type *)Malloc(sizeof(defined_type));
pt->typ_name = NULL;
pt->typ_external = false;
pt->typ_subtype = NULL; /* Until filled in with good value */
pt->typ_basic_type = arraytok; /* The type is "array" */
getoken();
if (token.kind != number) {
linerror(number_req); /** Assume zero **/
pt->UU.U12.typ_low = 0;
} else {
pt->UU.U12.typ_low = token.UU.value;
getoken();
}
/** Skip double point **/
if (token.kind == dot) {
getoken();
if (token.kind != dot)
linerror(dot_miss);
else
getoken();
} else
linerror(dot_miss);
if (token.kind != number) {
linerror(number_req); /** Assume low + 1 **/
pt->UU.U12.typ_high = pt->UU.U12.typ_low + 1;
} else {
pt->UU.U12.typ_high = token.UU.value;
getoken();
}
if (pt->UU.U12.typ_high <= pt->UU.U12.typ_low)
linerror(invalid_range);
if (token.kind == comma)
pt->typ_subtype = parse_subarray(); /* , <subarray> */
else if (token.kind == clsround) {
getoken();
if (token.kind == oftok) {
getoken();
pt->typ_subtype = parse_type(); /* ) of <type> */
/*** ensure_type_named(typ_subtype); *NO* **/
} else { /*if*/
errfind(clsround_miss, P_expset(SET, 1L << ((long)semicolon)));
/* ) garbage */
backtoken();
}
} else {
errfind(clsround_miss,
P_expset(SET, (1L << ((long)oftok)) | (1L << ((long)semicolon))));
backtoken();
}
if (pt->typ_subtype == NULL) { /*with*/
Free(pt); /* Not essential -could waste it */
return NULL;
} else { /*if*/
pt->typ_min_size = (pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1) *
pt->typ_subtype->typ_min_size;
pt->typ_max_size = (pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1) *
pt->typ_subtype->typ_max_size;
pt->typ_nesting = pt->typ_subtype->typ_nesting + 1;
return pt;
}
/*if*/
} /*parse_subarray*/
/* Parse Type 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'.
*/
Static defined_type *parse_type()
{
defined_type *Result, *pt;
named_type *pnt;
boolean loc_err;
named_type *father, *son;
long SET[3];
/* 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
*/
if (token.kind == ident) { /* <id> */
if (find_type(typeptr, &token.UU.name, &father, &son))
return (son->nty_type);
linerror(id_not_declared);
return Result;
} else if ((unsigned long)token.kind < 32 &&
((1L << ((long)token.kind)) &
((1L << ((long)longtok + 1)) - (1L << ((long)chartok)))) != 0) {
/* p2c: rpcc.p, line 2223: Note:
* Line breaker spent 1.4+4.47 seconds, 441 tries on line 2691 [251] */
return (simple_descriptor[(long)token.kind - (long)chartok]);
} else if (token.kind == arraytok) {
getoken();
if (token.kind != opnround) {
linerror(opnround_miss);
backtoken();
return NULL;
} else
return (parse_subarray());
} else if (token.kind == accesstok) {
pt = (defined_type *)Malloc(sizeof(defined_type));
pt->typ_basic_type = token.kind;
pt->typ_external = false;
getoken();
pt->typ_subtype = parse_type();
ensure_type_named(pt->typ_subtype);
if (pt->typ_subtype == NULL) /*if*/
return pt;
pt->typ_nesting = pt->typ_subtype->typ_nesting; /* No extra index */
pt->typ_min_size = 4; /* <tbd> */
pt->typ_max_size = pt->typ_subtype->typ_max_size + 4; /* <tbd> */
return pt;
} else if (token.kind == recordtok) {
pt = (defined_type *)Malloc(sizeof(defined_type));
Result = pt;
pt->typ_basic_type = token.kind;
pt->typ_external = false;
pt->typ_subtype = NULL; /* subtype is meaningless */
pt->UU.typ_fields = NULL; /* List of fields currently empty */
pt->typ_nesting = 0; /* Unless we find nesting in a subtype */
pt->typ_min_size = 0; /* Initialise total */
pt->typ_max_size = 0; /* Initialise total */
getoken();
while (token.kind == ident) { /*while token.kind=ident*/
pnt = (named_type *)Malloc(sizeof(named_type));
/** It's ok, create an element **/
pnt->nty_name = token.UU.name;
getoken();
if (token.kind != colon) /* : (or ignore)*/
linerror(colon_miss);
else
getoken();
pnt->nty_type = parse_type(); /* Analyse a type declaration*/
if (pnt->nty_type != NULL) /*if ok*/
{ /* Unless serious error, */
if (pnt->nty_type->typ_nesting > pt->typ_nesting)
/* Find max. nesting */
pt->typ_nesting = pnt->nty_type->typ_nesting;
pt->typ_min_size += pnt->nty_type->typ_min_size;
pt->typ_max_size += pnt->nty_type->typ_max_size;
insert_named_type(pnt, &pt->UU.typ_fields);
ensure_type_named(pnt->nty_type); /* Needed for FORTRAN? */
}
getoken(); /* Read next token: ";" */
if (token.kind != semicolon) {
/** Error recovery: Skip tokens until a good token is found **/
errfind(semicol_miss,
P_expset(SET,
(1L << ((long)semicolon)) | (1L << ((long)endtok))));
if (token.kind == semicolon) /** Skip it **/
getoken();
} else /** Semicolon found **/
getoken();
}
/*with*/
if (token.kind != endtok)
errfind(endtok_miss, P_expset(SET, 1L << ((long)endtok)));
getoken(); /* skip the END */
if (token.kind == recordtok)
return Result;
linerror(record_miss);
if (token.kind == semicolon) /* Assume he forgot RECORD */
backtoken();
return Result;
} else if (token.kind == sequence) {
pt = (defined_type *)Malloc(sizeof(defined_type));
pt->typ_basic_type = token.kind;
Result = pt;
get_size(pt);
getoken();
if (token.kind != oftok) { /** But ignore it **/
linerror(oftok_miss);
return Result;
}
getoken();
pt->typ_external = false;
pt->typ_subtype = parse_type();
/** ensure_type_named(typ_subtype); *NO* not needed **/
pt->typ_nesting = pt->typ_subtype->typ_nesting + 1;
pt->typ_min_size = 2;
pt->typ_max_size = pt->typ_subtype->typ_max_size *
(pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1) + 2;
/*if*/
return Result;
} else if ((unsigned long)token.kind < 32 &&
((1L << ((long)token.kind)) &
((1L << ((long)stringtok)) | (1L << ((long)substring)))) != 0) {
/* p2c: rpcc.p, line 2223: Note:
* Line breaker spent 3.1+1.80 seconds, 509 tries on line 2806 [251] */
pt = (defined_type *)Malloc(sizeof(defined_type));
Result = pt;
pt->typ_basic_type = token.kind;
get_size(pt);
pt->typ_subtype = simple_descriptor[0];
pt->typ_external = false;
if (pt->typ_basic_type == stringtok) { /*with*/
pt->typ_nesting = 2; /* Can be 2 or 1 needed actually. */
pt->typ_max_size = pt->UU.U12.typ_high + 2;
pt->typ_min_size = 2;
return Result;
}
pt->typ_nesting = 1;
pt->typ_max_size = pt->UU.U12.typ_high + 4;
pt->typ_min_size = 4;
return Result;
} else {
linerror(ill_basic_type);
loc_err = true;
backtoken();
return NULL;
}
return Result;
/* Simple types */
/* ARRAY ( <subarray> */
/* ACCESS <type> */
/* R E C O R D */
/* SEQUENCE (...) OF <type>*/
/* Substring */
/*if*/
} /*parse_type*/
/* p2c: rpcc.p, line 2225: Warning: Unrecognized character in file [247] */
/* 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.
*/
Static Void parse_pragma()
{
id_name pragma_name; /* Name of pragma being invoked */
block_table *blk; /* Pointer to block refered to */
block_table *block_father; /* dummy */
named_type *nty; /* Pointer to named type referred to */
named_type *type_father; /* dummy */
long i; /* Loop index */
defined_type *typ; /* New type if needed for external */
id_list *param; /* Pointer to relevant parameter */
long SET[3], SET1[3], SET2[3], SET3[3], SET4[3], SET5[3], SET6[3];
/*parse_pragma*/
if (expected(ident, P_expset(SET, 1L << ((long)semicolon))))
{ /*if got pragma name*/
pragma_name = token.UU.name;
if (expected(opnround, P_expset(SET1, 1L << ((long)semicolon)))) {
if (expected(ident, P_expset(SET2, 1L << ((long)semicolon)))) {
/* The TIMEOUT pragma allows one to define the maximum time allowed
for a procedure or function. It is represented by the blk_timeout parameter
for that procedure.
*/
if (!strncmp(pragma_name.str, "timeout ",
sizeof(char_name))) {
if (find_block(&token.UU.name, &block_father, &blk)) {
if (expected(comma, P_expset(SET3, 1L << ((long)semicolon)))) {
if (expected(number, P_expset(SET4, 1L << ((long)semicolon)))) {
blk->blk_timeout = token.UU.value;
if (expected(clsround,
P_expset(SET5, 1L << ((long)semicolon))))
expected(semicolon, P_expset(SET6, 1L << ((long)semicolon)));
/*fine - no more to do. */
}
}
}
/* The CONCURRENT pragma allows one to specify that the execution of a
procedure must continue in parallel with the client.
It is represented by the blk_concurrent parameter for that procedure.
The CAST pragma allows one to specify that no reply message is used
for a procedure.
*/
} else if (!strncmp(pragma_name.str, "concurrent ",
sizeof(char_name)) ||
!strncmp(pragma_name.str, "cast ",
sizeof(char_name))) {
while (token.kind == ident) { /*while*/
if (find_block(&token.UU.name, &block_father, &blk)) {
if (pragma_name.str[1] == 'o')
blk->blk_concurrent = true;
else
blk->blk_cast = true;
} else /*if*/
{ /*not found*/
printf(
"RPCC: PRAGMA CAST or CONCURRENT must refer to previously defined procedure\n");
linerror(id_not_declared);
}
getoken(); /* Get the comma or clsround */
if (token.kind == comma)
expected(ident, P_expset(SET3,
(1L << ((long)clsround)) | (1L << ((long)semicolon))));
/*loop*/
}
if (token.kind == clsround)
expected(semicolon, P_expset(SET3, 1L << ((long)semicolon)));
/*fine - no more to do. */
else {
linerror(clsround_miss);
if (token.kind != semicolon)
expected(semicolon, P_expset(SET3, 1L << ((long)semicolon)));
/*dummy*/
}
/* If a type is external, it's name will be used in the name of the
marshalling routines. Therefore, we must ensure that the name of
the type is the name specified, and not another type (such as
a simple type) to which it was declared equivalent.
*/
} else if (!strncmp(pragma_name.str, "external_marshalling ",
sizeof(char_name))) {
if (find_type(typeptr, &token.UU.name, &type_father, &nty)) {
if (nty->nty_type->typ_name != nty)
{ /* If type name is different */
typ = (defined_type *)Malloc(sizeof(defined_type));
/* Make a new type */
*typ = *nty->nty_type; /* like the last one */
typ->typ_name = nty; /* except named after us */
nty->nty_type = typ; /* and use that instead. */
}
/*if*/
nty->nty_type->typ_external = true;
nty->nty_type->typ_nesting = 0;
external_marshalling = true;
} else {
printf(
"RPCC: PRAGMA EXTERNAL_MARSHALLING must refer to previously defined type\n");
linerror(id_not_declared);
}
if (expected(clsround, P_expset(SET3, 1L << ((long)semicolon)))) {
expected(semicolon, P_expset(SET4, 1L << ((long)semicolon)));
/*fine - no more to do. */
/* The CALL_STATUS pragma allows one parameter of a procedure or function
to be declared as a status parameter. In this case, if an error occurs
on the call, that parameter will be set to the status value, and the
other parameters will be undefined (unchanged in fact).
The parser sets up a pointer, blk_status_param, from the procedure
to the parameter to indicate this.
*/
}
} else if (!strncmp(pragma_name.str, "call_status ",
sizeof(char_name))) {
if (!find_block(&token.UU.name, &block_father, &blk)) {
printf(
"RPCC: PRAGMA CALL_STATUS: First arg (proc/func name) not (yet) declared\n");
linerror(id_not_declared);
} else if (expected(comma, P_expset(SET3, 1L << ((long)semicolon)))) {
if (expected(ident, P_expset(SET4, 1L << ((long)semicolon)))) {
if (!find_param(&token.UU.name, blk->list, ¶m)) {
printf(" RPCC: PRAGMA CALL_STATUS:\n");
printf(" Second argument must be formal param. of proc/func\n");
linerror(id_not_declared);
} else { /*if*/
if (blk->blk_status_param != NULL) {
printf("RPCC: Proc/func already has a CALL_STATUS parameter\n");
linerror(twice_declared);
} else
blk->blk_status_param = param;
}
}
}
if (expected(clsround, P_expset(SET3, 1L << ((long)semicolon)))) {
expected(semicolon, P_expset(SET4, 1L << ((long)semicolon)));
/*fine - no more to do. */
/* Unknown PRAGMAs could be ADA ones or goodness knows what. We don't
even set warning status, we ignore them.
*/
}
} else {
printf("RPCC: Ignoring unknown pragma \"");
for (i = 0; i < pragma_name.len; i++)
putchar(pragma_name.str[i]);
printf("\"\n"); /* Ignore unknown pragma */
find_tok(P_expset(SET3, 1L << ((long)semicolon)));
}
}
}
}
getoken(); /* skip semicolon */
/*if good PRAGMA <name> ( <id> etc */
}
/* p2c: rpcc.p, line 2378: Warning: Unrecognized character in file [247] */
/**********************************************************************
TYPE_DECLARE
**********************************************************************
Parses the complete TYPE declaration section
<typedecl> :: <id> IS <type> ; <typedecl>
| <void>
On entry,
The token (TYPE) has been read
On exit,
The next token (PROCEDURE, etc) has been read.
*/
Static Void type_declare()
{
named_type *pnt;
long SET[(long)functok / 32 + 2];
long SET1[(long)functok / 32 + 2];
while (token.kind != (int)functok && token.kind != (int)proctok) {
if (token.kind == pragmatok) {
parse_pragma();
continue;
}
if (token.kind != typetok) {
P_addset(P_expset(SET, 0L), (int)proctok);
P_addset(SET, (int)functok);
/** Error recovery: Skip all token until a good token is found **/
errfind(type_miss, P_addset(SET, (int)typetok));
continue;
}
/** We are sure that we found a TYPE declaration **/
getoken();
if (token.kind != ident) {
P_addset(P_expset(SET1, 0L), (int)proctok);
P_addset(SET1, (int)functok);
/** Error recovery: Skip all token until a good token is found **/
errfind(ident_req, P_addset(SET1, (int)typetok));
continue;
}
pnt = (named_type *)Malloc(sizeof(named_type));
pnt->nty_name = token.UU.name; /* <id> */
getoken();
if (token.kind != istok) /* IS */
linerror(istok_miss);
else
getoken();
pnt->nty_type = parse_type(); /* <type> */
if (pnt->nty_type != NULL) {
insert_named_type(pnt, &typeptr); /* Put into the type list */
if (pnt->nty_type->typ_name == NULL) /* Link type back to name */
pnt->nty_type->typ_name = pnt;
}
getoken(); /* Read next token */
/* ; */
if (token.kind != semicolon) {
P_addset(P_expset(SET1, 0L), (int)semicolon);
P_addset(SET1, (int)proctok);
/** Error recovery: Skip tokens until a good token is found **/
errfind(semicol_miss, P_addset(SET1, (int)functok));
if (token.kind == semicolon) /** Skip it **/
getoken();
} else /** Semicolon found **/
getoken();
} /*end_while token = typetok*/
/*else_if, token <> ident */
/*else_if, token <> typetok */
} /*TYPE_DECLARE*/
/* Local variables for parse_parameter_list: */
struct LOC_parse_parameter_list {
id_list *headlist;
} ;
/*____________________________________________________________________________
FND_IDLIST
*/
Local id_list *fnd_idlist(name, last, head, LINK)
id_name *name;
id_list **last, *head;
struct LOC_parse_parameter_list *LINK;
{
/****
* This function check whether 'name' is already in the list pointed by 'head'
* Returns in 'last' last element of the list or the previous element if found.
* Returns pointer to 'name' if succesful, nil otherwise
*****/
id_list *scan;
boolean found;
scan = head; /** head pointer to the list to check **/
*last = head;
found = false;
while (scan != NULL && !found) {
if (!strncmp(scan->name.str, name->str, sizeof(char_name)))
found = true;
else {
*last = scan;
scan = scan->next;
}
}
return scan; /** Returns element or nil **/
} /*FND_IDLIST*/
/*_____________________________________________________________________________
GET_IDLIST
*/
Local id_list *get_idlist(LINK)
struct LOC_parse_parameter_list *LINK;
{
/****
* This function builds a list of identifier and returns a pointer
* to the header. Returns NIL in case of error (No tokens are skipped!!)
*****/
id_list *localist, *last, *scan;
named_type *junk1, *junk2;
long SET[3];
localist = NULL;
do {
getoken();
/** Get a parameter definition **/
if (token.kind != ident)
errfind(ident_req,
P_expset(SET, (1L << ((long)comma)) | (1L << ((long)ident)) |
(1L << ((long)colon))));
if (token.kind == ident) {
/****************************
* Check if this identifier was already declared.
* There are 3 lists in which we check:
1) list of global types.
2) list of all variables declared in this block,
pointed by headlist.
3) list of variables read in this functions,
pointed by localist.
*******************************/
if (find_type(typeptr, &token.UU.name, &junk1, &junk2) |
(fnd_idlist(&token.UU.name, &scan, LINK->headlist, LINK) != NULL) |
(fnd_idlist(&token.UU.name, &last, localist, LINK) != NULL))
/** But ignore it!!! **/
linerror(twice_declared);
else {
scan = (id_list *)Malloc(sizeof(id_list));
scan->name = token.UU.name;
scan->next = NULL;
if (last == NULL) /** Empty list **/
localist = scan;
else
last->next = scan;
}
getoken();
} /** kind = ident **/
} while (token.kind == comma);
return localist;
/** Add 'name' to the list, this is done
* adding in QUEUE, do not change this! **/
} /*GET_IDLIST*/
/******************************************************************************
*
* BLOCK DECLARATION ANALIZER
*
*******************************************************************************/
/* Parse a list of parameters
==========================
<paramlist> :: <idlist> : <direction> <type>
<idlist> :: <id>
| <id> , <idlist>
<direction> :: <void> | IN | OUT | IN OUT
*/
Static Void parse_parameter_list(block)
block_table *block;
{
/*
This function builds a list of identifiers with their types associated.
On entry,
'block' describes a new procedure or function.
no fields need be filled in in 'block'.
On exit,
block.list Points to a list of paramaters;
block.nesting gives the number of indeces needed for (un)packing
block.blk_min_in gives the minimum size of the input parameters
block.blk_max_in gives the maximum size of the input parameters
block.blk_min_out gives the minimum size of the output parameters
block.blk_max_out gives the maximum size of the output parameters
* Small explanation:
* 1) get a list of identifier separate by commas. (id1, id2, id3, ....).
This list is pointed by 'identlist'.
* 2) get the type definition: according to PASCAL rules, token should be:
1) identifier, then we look in the TYPE list;
2) RPCL simple type;
We do NOT allow to declare RPCL structured type as procedure parameter
because PASCAL compilers do not allow the declaration of a structured
type as parameter. Example: suppose user declares:
PROCEDURE PLUTO(PIPPO IN : SEQUENCE[100] OF SHORT);
We can not expand in PASCAL statement:
PROCEDURE PLUTO(L_PIPPO : INTEGER; A_PIPPO: ARRAY[1..100] OF RPC_SHORT);
because the PASCAL compiler would complain.
Instead we manage this unpleasant situation in such a way:
a) User must declare a RPCL structured type in TYPE section declaration.
b) RPCC creates a TYPE declaration for that identifier and type ONLY
for the structured type embedded in such RPCL type
c) RPCC expand procedure parameter using such a definition.
Example: (RPCL User program)
TYPE
PAPERO = SEQUENCE(2000) OF SHORT;
PROCEDURE PLUTO(PIPPO IN : PAPERO);
will be expanded as: (RPCC output in PASCAL)
TYPE
PAPERO = ARRAY [1..2000] OF RPC_SHORT;
PROCEDURE PLUTO(L_PIPPO : INTEGER; A_PIPPO : PAPERO);
(Note: The length parameter now FOLLOWS the array - TBL)
* 3) If no error found fills the list of identifiers with their attributes:
direction and type AND
* 4) add to the global list pointed by 'headlist'.
* 5) 'Loop' until ')'.
* WARNING:
* The list of the identifiers build on point 1 is split. So in the 'code'
* generation we will produce the parameter's list in the same order as
* declared but not in 'comma' format. (Without commas, I mean). So:
* procedure bb( a,b,c : short);
* will be output as:
* procedure bb( a: short; b: short; c: short);
*
*****/
struct LOC_parse_parameter_list V;
id_list *identlist, *tailist, *last;
defined_type *ptr2type;
type_token direction;
boolean got_error;
long SET[(long)functok / 32 + 2];
/*_____________________________________________________________________________
main block of parse_parameter_list;
*/
got_error = false;
V.headlist = NULL; /** Pointer to the head of the list to bulid **/
do {
/** Get the list of identifiers (id1, id2, id3, ...) **/
identlist = get_idlist(&V);
/** Now 'identlist points to the header of this list **/
/** Get_idlist already reads next token **/
if (token.kind != colon) /** But ignore **/
linerror(colon_miss);
else
getoken();
/* Get direction attribute */
if ((unsigned long)token.kind >= 32 ||
((1L << ((long)token.kind)) &
((1L << ((long)intok)) | (1L << ((long)outok)))) == 0)
/* p2c: rpcc.p, line 2712: Note:
* Line breaker spent 1.7+2.23 seconds, 530 tries on line 3316 [251] */
direction = intok; /** Assume inout, perhaps forgotten **/
else {
direction = token.kind;
getoken();
if (direction == intok && token.kind == outok) {
direction = inoutok;
getoken();
}
}
/* Get type definition : <type>
Originally, the type had to be a named type, but now we can generate
an arbitrary name for an unnamed type. The name is needed for Pascal.
*/
ptr2type = parse_type(); /* Parse it */
ensure_type_named(ptr2type); /* Invent a name if necessary */
/* Fill in this information for each parameter name:
*/
if (identlist != NULL && ptr2type != NULL)
{ /** Else ignore this wrong definition **/
/* Find maximum nesting: */
if (ptr2type->typ_nesting > block->blk_nesting)
block->blk_nesting = ptr2type->typ_nesting;
/** Add direction and type attributes **/
if (V.headlist == NULL) /** Empty list **/
V.headlist = identlist;
else
tailist->next = identlist;
tailist = identlist;
do {
tailist->attr = direction;
tailist->id_type = ptr2type;
last = tailist;
tailist = tailist->next;
/* Accumulate total parameter size: */
if (((1L << ((long)direction)) &
((1L << ((long)intok)) | (1L << ((long)inoutok)))) != 0) {
block->blk_max_in += ptr2type->typ_max_size;
block->blk_min_in += ptr2type->typ_min_size;
}
if (((1L << ((long)direction)) &
((1L << ((long)outok)) | (1L << ((long)inoutok)))) != 0) {
block->blk_max_out += ptr2type->typ_max_size;
block->blk_min_out += ptr2type->typ_min_size;
}
} while (tailist != NULL);
tailist = last;
}
getoken();
if ((unsigned long)token.kind >= 32 ||
((1L << ((long)token.kind)) &
((1L << ((long)semicolon)) | (1L << ((long)clsround)))) == 0) {
/* p2c: rpcc.p, line 2712: Note:
* Line breaker spent 0.3+3.49 seconds, 557 tries on line 3376 [251] */
P_addset(P_expset(SET, 0L), (int)semicolon);
P_addset(SET, (int)clsround);
P_addset(SET, (int)functok);
P_addset(SET, (int)proctok);
/** 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, P_addset(SET, (int)ident));
switch (token.kind) {
case semicolon:
case clsround:
/* blank case */
break;
case ident: /** Continue analisys **/
backtoken();
break;
case colon:
case functok:
case proctok:
got_error = true;
backtoken();
break;
}
}
} while (!(token.kind == clsround || got_error));
block->list = V.headlist;
} /*parse_parameter_list*/
/**********************************************************************
BLOCK_DECLARE
***********************************************************************/
Static Void block_declare()
{
block_table block;
named_type *junk1, *scan;
block_table *blk, *junk2, *lastblock;
boolean localerr;
id_list *ascan;
long SET[(long)pragmatok / 32 + 2];
long SET1[(long)functok / 32 + 2];
do {
localerr = false;
block.blk_nesting = 0; /* Initialise indeces required */
block.blk_min_in = 0; /* Initialize parameter size counts */
block.blk_min_out = 0;
block.blk_max_in = 0;
block.blk_max_out = 0;
if (token.kind != (int)endtok && token.kind != (int)pragmatok &&
token.kind != (int)functok && token.kind != (int)proctok) {
P_addset(P_expset(SET, 0L), (int)proctok);
P_addset(SET, (int)functok);
P_addset(SET, (int)endtok);
errfind(proc_exp, P_addset(SET, (int)pragmatok));
}
if (token.kind == pragmatok)
parse_pragma();
else if (token.kind != endtok) {
/** Save block type **/
block.b_type = token.kind;
block.in_only = (token.kind == proctok); /* could be in_only */
getoken(); /* <ident> */
if (token.kind != ident) {
/** Error recovery: ignore, but do not build any block later **/
linerror(ident_req);
localerr = true;
} else {
block.name = token.UU.name;
if (find_type(typeptr, &token.UU.name, &junk1, &scan) |
find_block(&token.UU.name, &lastblock, &junk2)) {
/** Error recovery: ignore, but do not build any block later **/
linerror(twice_declared);
localerr = true;
}
}
getoken(); /* ( */
if (token.kind == opnround) { /* TBL 18.8.86 */
parse_parameter_list(&block); /* ... ) */
getoken();
} else {
if ((unsigned long)token.kind < 32 &&
((1L << ((long)token.kind)) & ((1L << ((long)inoutok)) |
(1L << ((long)intok)) | (1L << ((long)outok)))) != 0) {
/* p2c: rpcc.p, line 2846: Note:
* Line breaker spent 1.8+1.08 seconds, 946 tries on line 3474 [251] */
linerror(opnround_miss);
backtoken();
parse_parameter_list(&block); /* ... ) */
getoken();
} else
block.list = NULL;
}
if (block.b_type == functok) { /*functok*/
if (token.kind != return_) /** But ignore **/
linerror(return_miss);
else
getoken();
if (token.kind == ident) {
/** Scan the types' list **/
if (find_type(typeptr, &token.UU.name, &junk1, &scan))
block.return_ = scan->nty_type->typ_basic_type;
else {
linerror(id_not_declared);
localerr = true;
}
} else
block.return_ = token.kind;
if (((1L << ((long)block.return_)) &
((1L << ((long)longtok + 1)) - (1L << ((long)chartok)))) != 0) {
getoken();
block.blk_max_out +=
simple_descriptor[(long)block.return_ - (long)chartok]->typ_max_size;
block.blk_min_out +=
simple_descriptor[(long)block.return_ - (long)chartok]->typ_min_size;
} else {
localerr = true;
linerror(simtype_req);
}
} else { /*proctok*/
/* Check for OUT or INOUT parameters to a procedure */
ascan = block.list;
while (ascan != NULL) {
if (ascan->attr != intok)
block.in_only = false;
ascan = ascan->next;
} /*while*/
} /*procok*/
if (token.kind != semicolon) {
P_addset(P_expset(SET1, 0L), (int)semicolon);
P_addset(SET1, (int)proctok);
P_addset(SET1, (int)functok);
errfind(semicol_miss, P_addset(SET1, (int)endtok));
if (token.kind == semicolon)
getoken();
} else
getoken();
if (!localerr) {
blk = (block_table *)Malloc(sizeof(block_table));
*blk = block;
blk->next = NULL;
blk->blk_status_param = NULL;
blk->blk_cast = false;
blk->blk_concurrent = false;
if (runoptions[(long)timeout - (long)ccerncross].value)
blk->blk_timeout = timeout_val; /* default timout */
else
blk->blk_timeout = rpc_default_timeout;
if (lastblock == NULL) {
/** List empty, update blockptr **/
blockptr = blk;
} else
lastblock->next = blk;
}
/** Create a new element and save the name **/
}
} while (token.kind != endtok);
/*if kind <> endtok*/
} /*BLOCDECLARE*/
/*************************************************************************
Parser Initialisation
On exit,
The simple type descriptors are prepared for the more complex
types and parameters to be linked to.
*/
Static Void initialise_parser()
{
type_token t;
defined_type *WITH;
named_type *WITH1;
id_name *WITH2;
/*initialise_parser*/
for (t = chartok; (long)t <= (long)longtok; t = (type_token)((long)t + 1))
{ /*for*/
simple_descriptor[(long)t - (long)chartok] =
(defined_type *)Malloc(sizeof(defined_type));
WITH = simple_descriptor[(long)t - (long)chartok];
WITH->typ_basic_type = t;
WITH->typ_nesting = 0; /* No indeces are necessary for this type */
WITH->typ_subtype = NULL;
WITH->typ_name = (named_type *)Malloc(sizeof(named_type));
WITH1 = WITH->typ_name;
WITH1->nty_name.len = MAXIDLEN;
WITH1->nty_type = simple_descriptor[(long)t - (long)chartok];
WITH1->nty_next = NULL;
switch (t) {
case chartok:
case bytetok:
WITH->typ_max_size = 1;
break;
case shortok:
case integertok:
WITH->typ_max_size = 2;
break;
case real32tok:
case longtok:
WITH->typ_max_size = 4;
break;
case real48tok:
case real64tok:
WITH->typ_max_size = 8;
break;
case real128tok:
WITH->typ_max_size = 16;
break;
}/*end_case*/
WITH->typ_min_size = WITH->typ_max_size; /*with*/
}
memcpy(simple_descriptor[0]->typ_name->nty_name.str,
"rpc_char ", sizeof(char_name));
memcpy(simple_descriptor[(long)bytetok - (long)chartok]->typ_name->nty_name.str,
"rpc_byte ", sizeof(char_name));
memcpy(simple_descriptor[(long)shortok - (long)chartok]->typ_name->nty_name.str,
"rpc_short ", sizeof(char_name));
/* p2c: rpcc.p, line 2914:
* Note: Line breaker spent 0.0+1.82 seconds, 43 tries on line 3630 [251] */
memcpy(simple_descriptor[(long)integertok - (long)chartok]->typ_name->
nty_name.str, "rpc_integer ", sizeof(char_name));
/* p2c: rpcc.p, line 2914:
* Note: Line breaker spent 0.1+2.56 seconds, 52 tries on line 3634 [251] */
memcpy(simple_descriptor[(long)real32tok - (long)chartok]->typ_name->
nty_name.str, "rpc_real32 ", sizeof(char_name));
memcpy(simple_descriptor[(long)longtok - (long)chartok]->typ_name->nty_name.str,
"rpc_long ", sizeof(char_name));
/* p2c: rpcc.p, line 2914:
* Note: Line breaker spent 0.3+1.19 seconds, 41 tries on line 3640 [251] */
memcpy(simple_descriptor[(long)real48tok - (long)chartok]->typ_name->
nty_name.str, "rpc_real48 ", sizeof(char_name));
/* p2c: rpcc.p, line 2914:
* Note: Line breaker spent 0.1+0.89 seconds, 49 tries on line 3644 [251] */
memcpy(simple_descriptor[(long)real64tok - (long)chartok]->typ_name->
nty_name.str, "rpc_real64 ", sizeof(char_name));
/* p2c: rpcc.p, line 2914:
* Note: Line breaker spent 0.1+2.29 seconds, 49 tries on line 3648 [251] */
memcpy(simple_descriptor[(long)real128tok - (long)chartok]->typ_name->
nty_name.str, "rpc_real128 ", sizeof(char_name));
/* p2c: rpcc.p, line 2914:
* Note: Line breaker spent 0.0+4.35 seconds, 52 tries on line 3652 [251] */
for (t = chartok; (long)t <= (long)longtok; t = (type_token)((long)t + 1))
{ /* strip trailing spaces */
WITH = simple_descriptor[(long)t - (long)chartok];
WITH1 = WITH->typ_name;
WITH2 = &WITH1->nty_name;
while (WITH2->str[WITH2->len - 1] == ' ')
WITH2->len--;
}
number_of_invented_types = 0;
external_marshalling = false; /* Not invoked yet */
}
/*****************************************************************
*
* PARSER, MAIN LOOP
*
******************************************************************/
Static Void parser()
{
initialise_parser();
/** Look for 'PACKAGE' **/
getoken();
if (token.kind != package) /** Ignored if missed **/
linerror(package_miss);
else
getoken();
/** Look for 'unit - name' **/
if (token.kind != ident) /*Ignore*/
linerror(ident_req);
else { /*if*/
unitname = token.UU.name;
getoken();
}
/** Look for 'is' **/
if (token.kind != istok) /*Ignore*/
linerror(istok_miss);
else
getoken();
/** Look for 'type' **/
type_declare();
/** Returns with the next token already read **/
if (token.kind == endtok) {
linerror(blocks_req);
return;
}
block_declare();
if (token.kind != endtok)
linerror(endtok_miss);
else
getoken();
if (token.kind != ident)
linerror(ident_req);
else {
if (strncmp(token.UU.name.str, unitname.str, sizeof(char_name)))
linerror(bad_name);
}
getoken();
if (token.kind != semicolon)
linerror(semicol_miss);
/*if*/
} /*PARSER*/
/* Code generation (PILS, FORTRAN generation in separate files)
*/
/* CODEFOR
Top-down RPC compiler: Code generator for FORTRAN
====================== ==========================
History:
Nov 88 Composite types and pointers; arrays of named types.
FORTRAN version made from Pascal/C versions! (TBL)
(Talk about backward steps!?!)
8 May 1988 detach_xxx and close_xxx and S_xxxx common block introduced.
22 Jun 1989 REQUEST is now declared INTEGER*2 as it is UPK_SHORT()-ed
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;
2. RPC_END_CALL_FOR must dispose of the message
3. RPC_CALL must leave m_index set to return_header_length
4. On entry into the server stub, m_index must be = call_header_length-4
5. The routine RPC_INIT_RETURN_FOR must set it to return_header_length
6. PCK/UPK_STRING_FOR must pack and unpack strings, and post-align.
7. PCK/UPK_SUBSTRING_FOR must pack and unpack substrings, and post-align.
8. RPC_SET_ERROR must set the m_status field of the message as given.
9. RPC_ATTACH_STUB_FOR is a fortran callable rpc_attach_stub
10. RPC_DETACH_STUB_FOR is a fortran callable rpc_detach_stub
11. RPC_OPEN_FOR is a fortran callable rpc_open
12. RPC_CLOSE_FOR is a fortran callable rpc_close
13. PCK/UPK_xxxx_FOR are the packing/unpacking routines Fortran callable.
14. RPC_NO_RETURN must set the message status to "Normal" to inhibit reply.
VAX/FORTRAN-isms in code produced by this module:
o The long names and embedded underscore characters in identifiers;
o The STRUCTURE/RECORD types (if used);
o The length specification on INTEGER for rpc_short & rpc_long (if used);
o The BYTE data type for rpc_byte (if used).
Restrictions:
1. The data types are restricted to VAX/FORTRAN data types: No pointers
but record types are allowed.
Note:
1. The PARAMETER statements generated to define the two RPC error
codes produced by a server stub should match RPC$CONST always.
*/
/*___________________________________________________________________________
Convert character to Upper case
*/
Static Char upper_case(ch)
Char ch;
{
if (islower(ch))
return _toupper(ch);
else
return ch;
}
/*___________________________________________________________________________
Write out one identifier (in uppercase if FORTRAN)
*/
Static Void write_name(where, name)
FILE **where;
id_name *name;
{
long a, FORLIM;
FORLIM = name->len;
for (a = 0; a < FORLIM; a++) {
if (omode == vaxfor)
fputc(upper_case(name->str[a]), *where);
else
putc(name->str[a], *where);
}
}
/*___________________________________________________________________________
Write out component expression (in uppercase if FORTRAN)
------------------------------
*/
Static Void write_exp(where, expr)
FILE **where;
expression *expr;
{
long a, FORLIM;
FORLIM = expr->len;
for (a = 0; a < FORLIM; a++) {
if (omode == vaxfor)
fputc(upper_case(expr->str[a]), *where);
else
putc(expr->str[a], *where);
}
}
/*___________________________________________________________________________
Write a quoted string padded to 40 characters
*/
Static Void write_name_padded(op_file, name, ch)
FILE **op_file;
id_name name;
Char ch;
{
/*write_name_padded*/
putc(ch, *op_file);
write_name(op_file, &name);
fprintf(*op_file, "%*c", (int)(rpc_name_length - name.len + 1), ch);
}
/*=============================================================================
FORTRAN-sepcific procedures
*/
/*____________________________________________________________________________
Code generator error
--------------------
Code generator errors are internal errors or target-dependent error.
*/
Static Void codefor_error(why)
Char *why;
{
printf(" RPCC: **** Error: %.*s\n", error_length, why);
printf(" (Error detected at FORTRAN code generator stage.)\n");
_Escape(0);
}
/*___________________________________________________________________________
Indenting algorithm
*/
Static long IndFor(level)
long level;
{
return (level * 3 + 3);
}
/*___________________________________________________________________________
Start a Continuation Line
*/
Static Void continuation()
{
fprintf(op_file, "\n +");
}
/*___________________________________________________________________________
Append a FORTRAN index to an array expression
Level = 1 => RPC_A used,
Level = 2 => RPC_B used etc...
*/
Static Void append_index_for(expr, level)
expression *expr;
long level;
{
format(expr, "$(RPC_ ");
append_1(expr, (Char)(level + 64));
append_1(expr, ')');
}
/*___________________________________________________________________________
Generate procedure name to (un)pack a simple type or descriptor
---------------------------------------------------------------
Used for the function return result.
| generates: upk/pck_ttt(rpc_p_buf,
*/
Static Void pack_simple_for(where, what, topack)
FILE **where;
type_token what;
boolean topack;
{
fprintf(*where, " CALL ");
if (topack)
fprintf(*where, "PCK_");
else
fprintf(*where, "UPK_");
switch (what) {
case chartok:
fprintf(*where, "CHAR");
break;
case bytetok:
fprintf(*where, "BYTE");
break;
case shortok:
fprintf(*where, "SHORT");
break;
case integertok:
fprintf(*where, "INTEGER");
break;
case real32tok:
fprintf(*where, "REAL32");
break;
case real48tok:
fprintf(*where, "REAL48");
break;
case real64tok:
fprintf(*where, "REAL64");
break;
case real128tok:
fprintf(*where, "REAL128");
break;
case longtok:
fprintf(*where, "LONG");
break;
}
fprintf(*where, "_FOR(RPC_P_BUF,");
}
/*___________________________________________________________________________
Generate code to: Align on a 2**power byte boundary
Currently, only aligns on word boundaires, because that is all
we need.
*/
Static Void gen_align_for(power, level)
long power, level;
{
/*gen_align_for*/
fprintf(op_file, "%*cCALL RPC_ALIGN(RPC_P_BUF,%ld)\n",
(int)IndFor(level), ' ', power);
/* Extra runtime support needed here */
}
/*___________________________________________________________________________
Generate code to: (un)Pack a parameter of given type
---------------- ----------------------------------
This recursive procedure uses the 'level' parameter to control the
amount of indentation at each stage, and which rpc_<level> parameters
may be accessed by any given stage.
If the type is declared as 'EXTERNAL_MARSHALLING, then an external
procedure PCK_<typename>_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.
*/
Static Void gen_pack_type_for(where, expr, typ, level, topack)
FILE **where;
expression expr;
defined_type *typ;
long level;
boolean topack;
{
/* output file */
/* Expression for variable */
/* type descriptor */
/* indentation & rpc_<level> */
/* pack or unpack? */
Char ch;
named_type *scan;
defined_type *element; /* Array element type */
long depth; /* Depth of nesting of array element */
expression exp2, l_expr; /* Expression for the length of a string, etc */
expression s_expr; /* Expression for the start of a substring */
long i; /* Loop index */
long local_label; /* Record of last label we used here */
id_name *WITH1;
long FORLIM;
defined_type *WITH2;
named_type *WITH3;
/*_____________________________________________________________________________
Main block of gen_pack_type_for
*/
/*gen_pack_type_for*/
/* Generate a few useful expressions: */
ch = (Char)(level + 64); /*for RPC_A etc */
l_expr = expr; /* x */
prepend_1(&l_expr, '_'); /* _x */
s_expr = l_expr; /* _x */
prepend_1(&l_expr, 'L'); /* L_x */
prepend_1(&s_expr, 'S'); /* S_x */
if (typ->typ_external) {
fprintf(*where, "%*cCALL ", (int)IndFor(level), ' ');
if (topack)
fprintf(*where, "PCK_");
else
fprintf(*where, "UPK_");
write_name(&op_file, &typ->typ_name->nty_name);
fprintf(*where, "_FOR(RPC_P_BUF,");
write_exp(where, &expr);
fprintf(*where, ")\n");
return;
}
switch (typ->typ_basic_type) { /*case*/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S I M P L E
Here we assume that the names of the pck/upk routines are consistent
with the names rpc_xxx of the basic types. The exception is the code
for unpacking a character, which is going to be a bit wierd, because
of the descriptor.
*/
case chartok: /*simple type */
fprintf(*where, "%*cCALL ", (int)IndFor(level), ' ');
if (topack)
fprintf(*where, "PCK");
else
fprintf(*where, "UPK");
fprintf(*where, "_CHAR_FOR(RPC_P_BUF,");
write_exp(where, &expr);
fprintf(*where, ")\n");
break;
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok: /*simple type */
fprintf(*where, "%*cCALL ", (int)IndFor(level), ' ');
if (topack)
fprintf(*where, "PCK");
else
fprintf(*where, "UPK");
WITH1 = &typ->typ_name->nty_name; /* eg "_INTEGER" */
FORLIM = WITH1->len;
for (i = 3; i < FORLIM; i++)
fputc(upper_case(WITH1->str[i]), *where);
fprintf(*where, "_FOR(RPC_P_BUF,");
write_exp(where, &expr);
fprintf(*where, ")\n");
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A R R A Y
Example: DO 101 RPC_A=1,12
DO 102 RPC_B=1,10
...MYVAR(RPC_A,RPC_B)...
102 CONTINUE
101 CONTINUE
*/
case arraytok: /*arraytok*/
exp2 = expr;
depth = level;
ch = (Char)(depth + 64);
element = typ->typ_subtype;
format(&exp2, "$(RPC_ ");
append_1(&exp2, ch);
fprintf(*where, "%*cDO %ld, RPC_%c=1,%ld\n",
(int)IndFor(depth), ' ', next_label, ch,
typ->UU.U12.typ_high - typ->UU.U12.typ_low + 1);
next_label++; /* Get a new labels */
while (element->typ_basic_type == arraytok) {
WITH2 = element;
depth++;
ch = (Char)(depth + 64);
fprintf(*where, "%*cDO %ld, RPC_%c=1,%ld\n",
(int)IndFor(depth), ' ', next_label, ch,
WITH2->UU.U12.typ_high - WITH2->UU.U12.typ_low + 1);
next_label++; /* Get a new labels */
format(&exp2, "$,RPC_ ");
append_1(&exp2, ch);
element = element->typ_subtype; /*while*/
}
append_1(&exp2, ')');
local_label = next_label; /* Save label */
gen_pack_type_for(where, exp2, element, depth + 1, topack);
while (depth >= level) { /*while*/
local_label--; /* recalculate original label */
fprintf(*where, "%4ld%*cCONTINUE\n",
local_label, (int)(IndFor(depth) - 4), ' ');
/* Not END DO */
depth--; /* Come back out of nesting */
}
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*/
case recordtok: /*recordtok*/
/* R E C O R D */
scan = typ->UU.typ_fields;
while (scan != NULL) {
WITH3 = scan;
exp2 = expr;
append_1(&exp2, '.');
append_name(&exp2, WITH3->nty_name);
gen_pack_type_for(where, exp2, WITH3->nty_type, level, topack);
scan = WITH3->nty_next; /*while*/
}
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A C C E S S
*/
case accesstok: /*accesstok*/
codefor_error("No ACCESS (POINTER) type exists in FORTRAN! ");
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*/
case sequence: /*sequence*/
/* S E Q U E N C E */
if (level > 1)
codefor_error("SEQUENCE type not allowed within composite type.");
gen_pack_type_for(where, l_expr,
simple_descriptor[(long)integertok - (long)chartok],
level, topack);
/* p2c: rpcc.p, line 3388:
* Note: Line breaker spent 1.7 seconds, 59 tries on line 4184 [251] */
exp2 = expr;
format(&exp2, "A_$ "); /* Make an expression for the array*/
append_index_for(&exp2, level); /* Make expression for an element */
fprintf(*where, "%*c", (int)IndFor(level), ' ');
fprintf(*where, "DO %ld, RPC_%c=1, L_", next_label, ch);
write_exp(where, &expr);
putc('\n', *where);
local_label = next_label;
next_label++;
gen_pack_type_for(where, exp2, typ->typ_subtype, level + 1, topack);
fprintf(*where, "%4ld%*cCONTINUE\n",
local_label, (int)(IndFor(level) - 4), ' ');
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
In the server, strings are unpacked and the lengths fudged in the descriptor
by the routine UPK_VSTRING_FOR(buffer, string, length).
*/
case stringtok: /*stringtok*/
/* S T R I N G */
fprintf(*where, "%*c", (int)IndFor(level), ' ');
if (topack)
fprintf(*where, "CALL PCK_STRING_FOR");
else if (client)
fprintf(*where, "CALL UPK_STRING_FOR");
else
fprintf(*where, "CALL UPK_VSTRING_FOR");
fprintf(*where, "(RPC_P_BUF,");
write_exp(where, &expr);
if (!topack && !client)
fprintf(*where, ",%ld", typ->UU.U12.typ_high);
fprintf(*where, ")\n");
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S U B S T R I N G
*/
case substring: /*substring*/
fprintf(*where, "%*c", (int)IndFor(level), ' ');
if (topack)
fprintf(*where, "CALL PCK_SUBSTRING_FOR");
else
fprintf(*where, "CALL UPK_SUBSTRING_FOR");
fprintf(*where, "(RPC_P_BUF,A_");
write_exp(where, &expr);
putc(',', *where);
continuation(); /* Keep it in 72 characters */
fprintf(*where, "S_");
write_exp(where, &expr);
fprintf(*where, ",L_");
write_exp(where, &expr);
fprintf(*where, ")\n");
break;
}
}
/*___________________________________________________________________________
Generate code to: (un)Pack all parameters necessary
----------------- ---------------------------------
The dirn parameter is INtok or OUTok, to specify which parameters to unpack.
A string descriptor needs to be initialised, including the creation of the
string, at the server side, and the string has to be disposed of afterwards.
*/
Static Void Gen_Pack_For(where, head, dirn, topack)
FILE **where;
id_list *head;
type_token dirn;
boolean topack;
{
/* Output file */
/* Parameter list */
/* Parameter filter */
/* Pack, rather than unpack? */
expression expr;
defined_type *WITH1;
do {
WITH1 = head->id_type;
/* generate an expression for the variable: */
expr.len = 0; /* Expression for the variable */
append_name(&expr, head->name); /* expr is the param. name */
/* Pack or unpack
--------------
*/
if (head->attr == inoutok || head->attr == dirn) { /*if*/
deref = (client &&
!(runoptions[(long)byvalue - (long)ccerncross].value &&
head->attr == intok));
/* p2c: rpcc.p, line 3435:
* Note: Line breaker spent 1.3 seconds, 16 tries on line 4293 [251] */
/** not value param **/
/* and in-only param */
/*level*/
gen_pack_type_for(where, expr, head->id_type, 1L, topack);
}
/*with*/
head = head->next;
} while (head != NULL);
} /*Gen_Pack_For*/
/* (end of packing/unpacking)
*****************************************************************************
Generate: A type declaration in FORTRAN
This recursive procedure generates a definition of a type, given
a name and a type descriptor. It is impossible to generate a type
itself, as the name is buried within it in FORTRAN.
Examples
CHARACTER*80 MYSTR(10,2)
for
mystr: ARRAY[1..10, 1..2] OF STRING(80);
RECORD /MYSTRUCTURE/ MYVARIABLE(4)
for
myvariable: ARRAY[1..4] OF MYSTRUCTURE;
Note: In a client routine, a string 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.
*/
Static Void gen_type_decl_for(expr, pt, level)
expression expr;
defined_type *pt;
long level;
{
/* for the varaiable */
/* type structure */
/* indentation */
defined_type *scan;
expression exp2;
/*gen_type_decl_for*/
switch (pt->typ_basic_type) { /*with, case*/
case chartok:
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok: /* First token, simple type, courier type */
fprintf(op_file, "%*c", (int)IndFor(level), ' ');
switch (pt->typ_basic_type) { /*case*/
case chartok:
fprintf(op_file, "CHARACTER*1");
break;
case bytetok: /* @@ VAX ONLY */
fprintf(op_file, "BYTE");
break;
case integertok:
fprintf(op_file, "INTEGER");
break;
case real32tok:
fprintf(op_file, "REAL");
break;
case real48tok:
fprintf(op_file, "DOUBLE");
break;
case real64tok:
fprintf(op_file, "DOUBLE");
break;
case real128tok:
fprintf(op_file, "DOUBLE");
break;
case shortok: /* @@ VAX ONLY */
fprintf(op_file, "INTEGER*2");
break;
case longtok: /* @@ VAX ONLY */
fprintf(op_file, "INTEGER*4");
break;
}
putc(' ', op_file);
write_exp(&op_file, &expr); /* Example: rpc_char x */
putc('\n', op_file);
break;
/*simple type*/
case substring:
case stringtok: /*stringtok*/
/* Example: rpc_char x[81] */
fprintf(op_file, "%*c", (int)IndFor(level), ' ');
if (client && level == 1) /* 91024 */
fprintf(op_file, "CHARACTER*(*) ");
else
fprintf(op_file, "CHARACTER*%ld ", pt->UU.U12.typ_high);
write_exp(&op_file, &expr);
putc('\n', op_file);
break;
case sequence:
case arraytok: /*arraytok*/
/* example INTEGER MYARR(10,20) */
exp2 = expr;
append_1(&exp2, '(');
append_decimal(&exp2, pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1);
scan = pt->typ_subtype;
while (scan->typ_basic_type == arraytok) { /*while*/
append_1(&exp2, ',');
append_decimal(&exp2, scan->UU.U12.typ_high - scan->UU.U12.typ_low + 1);
scan = scan->typ_subtype;
}
append_1(&exp2, ')');
gen_type_decl_for(exp2, scan, level); /*non-array type*/
break;
case accesstok:
codefor_error("Package has pointers: Can't make FORTRAN stubs. ");
break;
case recordtok: /* VAX/FORTRAN ONLY! */
fprintf(op_file, "%*cRECORD ", (int)IndFor(level), ' ');
if (pt->typ_name == NULL)
codefor_error("Every structure must be named for VAX/FORTRAN. ");
else { /*if*/
putc('/', op_file);
write_name(&op_file, &pt->typ_name->nty_name);
fprintf(op_file, "/ ");
}
write_exp(&op_file, &expr);
putc('\n', op_file);
break;
}
}
/*_____________________________________________________________________________
Generate Common Block for this client
*/
Static Void gen_client_common()
{
/*gen_client_common*/
fprintf(op_file, " COMMON /C_");
write_name(&op_file, &unitname);
fprintf(op_file, "/ H_");
write_name(&op_file, &unitname);
fprintf(op_file, "\n INTEGER H_");
write_name(&op_file, &unitname);
putc('\n', op_file);
}
/*_____________________________________________________________________________
Generate Common Block for this server
*/
Static Void gen_server_common()
{
/*gen_server_common*/
fprintf(op_file, " COMMON /S_");
write_name(&op_file, &unitname);
fprintf(op_file, "/ P_");
write_name(&op_file, &unitname);
fprintf(op_file, "\n INTEGER P_");
write_name(&op_file, &unitname);
putc('\n', op_file);
}
/* Local variables for gen_dummies: */
struct LOC_gen_dummies {
long col;
} ;
Local Void comma_cont(name, LINK)
id_name name;
struct LOC_gen_dummies *LINK;
{
putc(',', op_file); /* Separate two parameters */
LINK->col++; /* Count characters */
if (LINK->col + name.len > 65) { /* Allow 5 spare */
continuation();
LINK->col = 6;
}
}
/*____________________________________________________________________________
Generate Parameter list
*/
Static Void gen_dummies(head)
id_list *head;
{
/* Generates the formal parameter list enclosed in brackets (a,b,c,d) */
struct LOC_gen_dummies V;
id_list *scan;
if (head == NULL) /*if list not NIL*/
return;
scan = head;
putc('(', op_file);
V.col = 40; /* upper limit to characters so far on line */
while (scan != NULL) { /*while*/
if (((1L << ((long)scan->id_type->typ_basic_type)) &
((1L << ((long)sequence)) | (1L << ((long)substring)))) != 0)
/* p2c: rpcc.p, line 3641: Note:
* Line breaker spent 0.2+2.71 seconds, 142 tries on line 4537 [251] */
fprintf(op_file, "A_");
write_name(&op_file, &scan->name);
V.col += scan->name.len + 2;
if (scan->id_type->typ_basic_type == substring) {
comma_cont(scan->name, &V);
fprintf(op_file, "S_");
write_name(&op_file, &scan->name);
V.col += scan->name.len + 2;
}
if (((1L << ((long)scan->id_type->typ_basic_type)) &
((1L << ((long)sequence)) | (1L << ((long)substring)))) != 0) {
/* p2c: rpcc.p, line 3641: Note:
* Line breaker spent 0.4+1.50 seconds, 142 tries on line 4552 [251] */
comma_cont(scan->name, &V);
fprintf(op_file, "L_");
write_name(&op_file, &scan->name);
V.col += scan->name.len + 2;
}
scan = scan->next;
if (scan != NULL)
comma_cont(scan->name, &V);
}
putc(')', op_file);
} /*gen_dummies*/
/*_____________________________________________________________________________
Generate local variables (server) / parameter (client)
------------------------------------------------------
This subroutine will generate
- The parameters to the client subroutine,
- or the local variables in the server.
*/
Static Void gen_params_for(head)
id_list *head;
{
expression a_expr, l_expr, s_expr, expr;
id_list *scan;
boolean simple_ref; /* Should simple variables be dereferenced? */
boolean composite_ref; /* what about composite variables? */
defined_type *WITH;
scan = head;
while (scan != NULL) { /*while*/
WITH = scan->id_type; /*with*/
/** Write the type's name if any otherwise the full declaration **/
/** Sequences and substrings MUST be expanded a little **/
expr.len = 0;
append_name(&expr, scan->name);
l_expr = expr; /* x */
prepend_1(&l_expr, '_'); /* _x */
s_expr = l_expr; /* _x */
a_expr = l_expr; /* _x */
prepend_1(&l_expr, 'L'); /* L_x */
prepend_1(&s_expr, 'S'); /* S_x */
prepend_1(&a_expr, 'A'); /* A_x */
switch (WITH->typ_basic_type) { /*case*/
case chartok:
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok:
case stringtok:
case recordtok:
case arraytok:
gen_type_decl_for(expr, scan->id_type, 1L);
break;
case sequence: /* a_xxx: tttt; */
gen_type_decl_for(a_expr, scan->id_type, 1L);
/* l_xxx: rpc_integer */
gen_type_decl_for(l_expr,
simple_descriptor[(long)integertok - (long)chartok],
1L);
break;
case substring: /* a_xxx: tttt; */
gen_type_decl_for(a_expr, scan->id_type, 1L);
gen_type_decl_for(s_expr,
simple_descriptor[(long)integertok - (long)chartok],
1L);
gen_type_decl_for(l_expr,
simple_descriptor[(long)integertok - (long)chartok],
1L);
break;
}
scan = scan->next;
}
} /*GEN_PARAMS_for*/
/*_________________________________________________________________________
Generate: A structure declaration in FORTRAN
==============================================
Example: STRUCTURE /structurename/
CHARACTER*80 fieldname
INTEGER fieldname2
END STRUCTURE
*/
Static Void gen_struct_for(pt, level)
defined_type *pt;
long level;
{
/* type structure */
/* indentation */
named_type *scan;
expression exp2;
/*gen_struct_for*/
if (pt->typ_basic_type != recordtok) /*with..if*/
return;
/* VAX/FORTRAN ONLY! */
fprintf(op_file, "%*cSTRUCTURE ", (int)IndFor(level), ' ');
if (pt->typ_name == NULL)
codefor_error("Every structure must be named for VAX/FORTRAN. ");
else { /*if*/
putc('/', op_file);
write_name(&op_file, &pt->typ_name->nty_name);
fprintf(op_file, "/ ");
}
putc('\n', op_file);
scan = pt->UU.typ_fields;
while (scan != NULL) { /*while*/
exp2.len = 0;
append_name(&exp2, scan->nty_name);
gen_type_decl_for(exp2, scan->nty_type, level + 1);
scan = scan->nty_next;
}
fprintf(op_file, "%*cEND STRUCTURE\n", (int)IndFor(level), ' ');
}
/*___________________________________________________________________________
Generate type definitions for whole package
===========================================
Example:
INTEGER P1
INTEGER*4 P2(3,3)
CHARACATER*80 P3(10)
*/
Static Void generate_types_for()
{ /*generate types*/
named_type *scan, *WITH;
defined_type *WITH1;
scan = typeptr;
while (scan != NULL) { /*while*/
WITH = scan;
WITH1 = WITH->nty_type;
if (WITH1->typ_basic_type == recordtok) { /*if*/
/* Now make the main type definition:
*/
gen_struct_for(WITH->nty_type, 1L);
putc('\n', op_file); /* Blank line */
}
scan = WITH->nty_next;
}
}
/* Local variables for client_gen_for: */
struct LOC_client_gen_for {
long proc_number;
} ;
Local Void gen_client_block(ptr, LINK)
block_table *ptr;
struct LOC_client_gen_for *LINK;
{
/****
* On each block, the client allocates 'RPC_integer' variables to pack or
* unpack parameters.
*****/
long a;
expression expr; /* Expression for return value */
long FORLIM;
/* Generate Header:
*/
fprintf(op_file, "%*c", (int)IndFor(1L), ' ');
if (ptr->b_type == functok) {
switch (ptr->return_) { /*case*/
case chartok:
fprintf(op_file, "CHARACTER*1");
break;
case bytetok:
case shortok:
case longtok:
case integertok:
fprintf(op_file, "INTEGER");
break;
case real32tok:
fprintf(op_file, "REAL");
break;
case real48tok:
case real64tok:
case real128tok:
fprintf(op_file, "DOUBLE");
break;
}
fprintf(op_file, " FUNCTION ");
write_name(&op_file, &ptr->name);
switch (ptr->return_) { /*case*/
case chartok:
/* blank case */
break;
case bytetok: /* @@ VAX ONLY */
fprintf(op_file, "*1");
break;
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok: /* ok as it is*/
break;
case shortok: /* @@ VAX ONLY */
fprintf(op_file, "*2");
break;
case longtok: /* @@ VAX ONLY */
fprintf(op_file, "*4");
break;
}
} else { /*if*/
fprintf(op_file, "SUBROUTINE ");
write_name(&op_file, &ptr->name);
}
gen_dummies(ptr->list); /* Generate formal parameter list */
putc('\n', op_file);
gen_client_common();
generate_types_for(); /* generate local types */
gen_params_for(ptr->list);
/* Local variables:
*/
fprintf(op_file, " INTEGER RPC_P_BUF");
FORLIM = ptr->blk_nesting + 64;
for (a = 65; a <= FORLIM; a++)
fprintf(op_file, ",RPC_%c", (Char)a);
putc('\n', op_file);
if (ptr->b_type == functok) /*if*/
{ /* Variable for return value */
format(&expr, "RPC_RET ");
gen_type_decl_for(expr,
simple_descriptor[(long)ptr->return_ - (long)chartok],
1L);
}
/* Declaration of RPC_CALL_STATUS function type
*/
if (ptr->blk_status_param != NULL) /*if*/
fprintf(op_file, " INTEGER*4 RPC_CALL_STATUS\n\n");
/* Code of routine starts here:
*/
fprintf(op_file, " CALL RPC_BEGIN_CALL_FOR(RPC_P_BUF, H_");
write_name(&op_file, &unitname);
fprintf(op_file, ",%ld,%ld,%ld,%ld)\n",
ptr->blk_max_in, ptr->blk_max_out, version_num, LINK->proc_number);
/** generate packing statements for IN & INOUT params **/
if (ptr->list != NULL)
Gen_Pack_For(&op_file, ptr->list, intok, true);
/** generate rpc_call and bookeeping **/
if (ptr->blk_status_param != NULL) {
fprintf(op_file, " ");
write_name(&op_file, &ptr->blk_status_param->name);
fprintf(op_file, "=RPC_CALL_STATUS(H_");
} else if (ptr->blk_cast)
fprintf(op_file, " CALL RPC_CAST(H_");
else
fprintf(op_file, " CALL RPC_CALL(H_");
write_name(&op_file, &unitname);
fprintf(op_file, ",RPC_P_BUF");
if (!ptr->blk_cast)
fprintf(op_file, ",%ld", ptr->blk_timeout);
fprintf(op_file, ")\n");
if (ptr->blk_status_param != NULL) {
fprintf(op_file, " IF (MOD(");
write_name(&op_file, &ptr->blk_status_param->name);
fprintf(op_file, ",2).NE.0) THEN\n");
}
/** if function: unpack return value **/
if (ptr->b_type == functok) { /*if*/
pack_simple_for(&op_file, ptr->return_, false);
fprintf(op_file, "RPC_RET)\n");
}
/** generate UNpacking statements for OUT and INOUT params **/
if (ptr->list != NULL)
Gen_Pack_For(&op_file, ptr->list, outok, false);
if (ptr->blk_status_param != NULL)
fprintf(op_file, " END IF\n");
/** clear up everything and exit **/
fprintf(op_file, " CALL RPC_END_CALL_FOR(RPC_P_BUF)\n");
if (ptr->b_type == functok) { /*if*/
fprintf(op_file, " ");
write_name(&op_file, &ptr->name);
fprintf(op_file, "=RPC_RET\n"); /* Define function value */
}
fprintf(op_file, " RETURN\n");
fprintf(op_file, " END\n\n");
/*with*/
/*if*/
} /*gen_client_block*/
Local Void gen_open(LINK)
struct LOC_client_gen_for *LINK;
{
if (!runoptions[(long)noautoinit - (long)ccerncross].value)
fprintf(op_file, "C Call this procedure at initialisation time ***\n");
fprintf(op_file, " SUBROUTINE OPEN_");
write_name(&op_file, &unitname);
putc('\n', op_file);
gen_client_common();
fprintf(op_file, " INTEGER STATUS\n");
fprintf(op_file, " CALL RPC_OPEN_FOR(STATUS,H_");
write_name(&op_file, &unitname);
putc(',', op_file);
continuation();
write_name_padded(&op_file, unitname, '\'');
fprintf(op_file, ")\n");
fprintf(op_file, " CALL RPC_REPORT_ERROR(STATUS)\n");
fprintf(op_file, " END\n\n");
} /*GEN_OPEN*/
Local Void gen_close(LINK)
struct LOC_client_gen_for *LINK;
{
fprintf(op_file, " SUBROUTINE CLOSE_");
write_name(&op_file, &unitname);
putc('\n', op_file);
gen_client_common();
fprintf(op_file, " INTEGER STATUS\n");
fprintf(op_file, " CALL RPC_CLOSE_FOR(STATUS,H_");
write_name(&op_file, &unitname);
fprintf(op_file, ")\n");
fprintf(op_file, " CALL RPC_REPORT_ERROR(STATUS)\n");
fprintf(op_file, " END\n\n");
} /*GEN_close*/
/*******************************************************************************
Client code generator
=====================
Generates one procedure or function for the client.
*/
Static Void client_gen_for()
{
struct LOC_client_gen_for V;
block_table *scan;
next_label = 100; /* An arbitrary starting label */
fprintf(op_file, "C CLIENT STUB routines for package ");
write_name(&op_file, &unitname);
fprintf(op_file, "\nC ====================\n");
fprintf(op_file, "C\n");
fprintf(op_file, "C Generated automatically by the RPC Compiler\n");
fprintf(op_file, "C \n");
/** Generate procedures **/
V.proc_number = 1;
scan = blockptr;
while (scan != NULL) {
gen_client_block(scan, &V);
V.proc_number++;
scan = scan->next;
}
gen_open(&V);
gen_close(&V);
} /*CLIENT_GEN_for*/
/* Local variables for server_gen_for: */
struct LOC_server_gen_for {
block_table *scan;
} ;
/*_____________________________________________________________________________
Generate server stub for one procedure
*/
Local Void gen_r_routine(LINK)
struct LOC_server_gen_for *LINK;
{
long a; /* Loop variable */
expression expr; /* Expression for the name of the function */
long FORLIM;
/*gen_r_routine*/
fprintf(op_file, " SUBROUTINE R_");
write_name(&op_file, &LINK->scan->name);
fprintf(op_file, "(RPC_P_BUF)\n");
fprintf(op_file, " INTEGER RPC_P_BUF");
if (LINK->scan->b_type == functok) { /* Declare function type */
putc('\n', op_file);
expr.len = 0;
append_name(&expr, LINK->scan->name);
gen_type_decl_for(expr,
simple_descriptor[(long)LINK->scan->return_ - (long)chartok], 1L);
}
FORLIM = LINK->scan->blk_nesting + 64;
for (a = 65; a <= FORLIM; a++)
fprintf(op_file, ",RPC_%c", (Char)a);
putc('\n', op_file);
generate_types_for(); /* Declare structure types */
gen_params_for(LINK->scan->list); /* Declare types of parameters */
/* Generate UNpacking statements for IN and INOUT params:
*/
if (LINK->scan->list != NULL)
Gen_Pack_For(&op_file, LINK->scan->list, intok, false);
/** generate call and bookeeping **/
fprintf(op_file, " CALL RPC_INIT_RETURN_FOR(RPC_P_BUF)\n");
if (LINK->scan->b_type == proctok && LINK->scan->in_only) {
if (runoptions[(long)concurrent - (long)ccerncross].value ||
LINK->scan->blk_concurrent)
fprintf(op_file, " CALL RPC_EARLY_RETURN(RPC_P_BUF)\n");
else if (LINK->scan->blk_cast)
fprintf(op_file, " CALL RPC_NO_RETURN(RPC_P_BUF)\n");
}
fprintf(op_file, " ");
/** if function: generate return variable, else just call subroutine.**/
if (LINK->scan->b_type == functok)
pack_simple_for(&op_file, LINK->scan->return_, true);
else
fprintf(op_file, "CALL ");
write_name(&op_file, &LINK->scan->name);
gen_dummies(LINK->scan->list);
if (LINK->scan->b_type == functok) { /*if*/
if (LINK->scan->list == NULL) /* Mandatory */
fprintf(op_file, "()");
putc(')', op_file);
}
putc('\n', op_file);
/** generate packing statements for OUT and INOUT params**/
if (LINK->scan->list != NULL)
Gen_Pack_For(&op_file, LINK->scan->list, outok, true);
fprintf(op_file, " END\n\n");
/* Blank line after each one */
}
/******************************************************************************
S E R V E R C O D E G E N E R A T O R
*************************************************
*/
Static Void server_gen_for()
{
struct LOC_server_gen_for V;
long i; /* Label counter for computed goto */
long proc_num;
/*_____________________________________________________________________________*/
/* Generate Main Server Procedure
------------------------------
*/
next_label = 100; /* An arbitrary starting label */
fprintf(op_file, "C SERVER STUB routines for package ");
write_name(&op_file, &unitname);
fprintf(op_file, "\nC ====================\n");
fprintf(op_file, "C\n");
fprintf(op_file, "C Generated automatically by the RPC Compiler\n");
fprintf(op_file, "C \n");
/* Generate individual routines for each procedure:
-----------------------------------------------
*/
V.scan = blockptr;
proc_num = 0;
while (V.scan != NULL) { /*while*/
proc_num++; /* Count the procedures */
gen_r_routine(&V); /* Generate the individual stub subroutines */
V.scan = V.scan->next;
}
/* Generate the main server stub subroutine:
----------------------------------------
*/
fprintf(op_file, "C\n");
fprintf(op_file, "C Main stub entry point\n");
fprintf(op_file, "C\n");
fprintf(op_file, " SUBROUTINE R_");
write_name(&op_file, &unitname);
fprintf(op_file, "(RPC_P_BUF)\n");
fprintf(op_file, " INTEGER RPC_P_BUF\n");
fprintf(op_file, " INTEGER*2 RPC_REQUEST\n");
fprintf(op_file, " INTEGER*4 STATUS\n");
fprintf(op_file, " INTEGER RPC_S_UNSUPPORTED_VERSION\n");
fprintf(op_file, " PARAMETER(RPC_S_UNSUPPORTED_VERSION=139624458)\n");
fprintf(op_file, " INTEGER RPC_S_BAD_PROCEDURE_NUMBER\n");
fprintf(op_file,
" PARAMETER(RPC_S_BAD_PROCEDURE_NUMBER=139624466)\n\n");
fprintf(op_file, " CALL UPK_SHORT_FOR(RPC_P_BUF, RPC_REQUEST)\n");
fprintf(op_file,
" IF ((RPC_REQUEST.NE.0).AND.(RPC_REQUEST.NE.%ld)) THEN\n",
version_num);
fprintf(op_file,
" CALL RPC_SET_ERROR(RPC_P_BUF,RPC_S_UNSUPPORTED_VERSION)\n");
fprintf(op_file, " ELSE\n");
fprintf(op_file, " CALL UPK_SHORT_FOR(RPC_P_BUF, RPC_REQUEST)\n");
fprintf(op_file,
" IF ((RPC_REQUEST.LE.0).OR.(RPC_REQUEST.GT.%ld)) THEN\n",
proc_num);
fprintf(op_file,
" CALL RPC_SET_ERROR(RPC_P_BUF,RPC_S_BAD_PROCEDURE_NUMBER)\n");
fprintf(op_file, " ELSE\n");
fprintf(op_file, " GOTO(10");
for (i = 2; i <= proc_num; i++) { /*for*/
if (i % 10 == 0) /*if*/
fprintf(op_file, "\n + ");
/* p2c: rpcc.p, line 4154:
* Note: Using % for possibly-negative arguments [317] */
fprintf(op_file, ",%ld", i * 10);
}
fprintf(op_file, "),RPC_REQUEST\n");
V.scan = blockptr; /* Make jump table: */
for (i = 1; i <= proc_num; i++) {
fprintf(op_file, "\n%5ld CALL R_", i * 10);
write_name(&op_file, &V.scan->name);
fprintf(op_file, "(RPC_P_BUF)\n");
fprintf(op_file, " GOTO 888\n");
V.scan = V.scan->next;
}
fprintf(op_file, " 888 CONTINUE\n\n");
fprintf(op_file, " END IF\n"); /* If good request */
fprintf(op_file, " END IF\n"); /* If good version */
fprintf(op_file, " END\n\n"); /* subroutine */
/* Generate Code to Attach stub to RPCRTS
--------------------------------------
*/
if (!runoptions[(long)noautoinit - (long)ccerncross].value)
fprintf(op_file, "C Call this procedure at initialisation time ***\n");
/* p2c: rpcc.p, line 4227:
* Note: Line breaker spent 1.2 seconds, 1 tries on line 5165 [251] */
fprintf(op_file, " SUBROUTINE ATTACH_");
write_name(&op_file, &unitname);
putc('\n', op_file);
gen_server_common();
fprintf(op_file, " EXTERNAL R_");
write_name(&op_file, &unitname);
fprintf(op_file, "\n INTEGER STATUS\n\n");
fprintf(op_file, " CALL RPC_ATTACH_STUB_FOR(STATUS,R_");
write_name(&op_file, &unitname);
putc(',', op_file);
continuation();
write_name_padded(&op_file, unitname, '\'');
fprintf(op_file, ",P_");
write_name(&op_file, &unitname);
fprintf(op_file, ")\n");
fprintf(op_file, " CALL RPC_REPORT_ERROR(STATUS)\n");
fprintf(op_file, " END\n\n");
/* Generate Code to Detach stub from RPCRTS
----------------------------------------
*/
fprintf(op_file, " SUBROUTINE DETACH_");
write_name(&op_file, &unitname);
putc('\n', op_file);
gen_server_common();
fprintf(op_file, " CALL RPC_DETACH_STUB_FOR(P_");
write_name(&op_file, &unitname);
fprintf(op_file, ")\n");
fprintf(op_file, " END\n");
} /*SERVER_GEN_FOR*/
/* CODEPILS
Top-down RPC compiler: Code generator for PILS
====================== =======================
History:
Dec 88 PILS version made from FORTRAN versions (LTR)
Requirements of the run-time system:
1. rpc_BEGIN_CALL_PILS must
o Set up the 'procedure number' and 'version' fields;
o Leave the m_index pointer to call_header_length;
2. rpc_END_CALL_PILS must dispose of the message
3. rpc_CALL must leave m_index set to return_header_length
4. On entry into the server stub, m_index must be = call_header_length-4
5. The routine rpc_INIT_RETURN_PILS must set it to return_header_length
6. pck/upk_string_PILS must pack & unpack strings, and post-align.
7. pck/upk_substring_PILS must pack & unpack substrings, and post-align.
8. rpc_SET_ERROR must set the m_status field of the message as given.
9. rpc_ATTACH_STUB_PILS is a fortran callable rpc_attach_stub
10. rpc_OPEN_PILS is a fortran callable rpc_open
11. pck/upk_xxxx_PILS are the packing/unpacking routines Fortran callable.
Restrictions:
No pointers
No Records
{___________________________________________________________________________
Write out one identifier
*/
Static Void write_name_pils(where, name)
FILE **where;
id_name *name;
{
long a, FORLIM;
FORLIM = name->len;
for (a = 0; a < FORLIM; a++)
putc(name->str[a], *where);
}
/*___________________________________________________________________________
Write out component expression
------------------------------
*/
Static Void write_exp_pils(where, expr)
FILE **where;
expression *expr;
{
long a, FORLIM;
FORLIM = expr->len;
for (a = 0; a < FORLIM; a++)
putc(expr->str[a], *where);
}
/*___________________________________________________________________________
Write a quoted string padded to 40 characters
*/
Static Void write_name_padded_pils(op_file, name, ch)
FILE **op_file;
id_name name;
Char ch;
{
/*write_name_padded*/
putc(ch, *op_file);
write_name(op_file, &name);
fprintf(*op_file, "%*c", (int)(rpc_name_length - name.len + 1), ch);
}
/*=============================================================================
PILS-sepcific procedures
*/
/*____________________________________________________________________________
Code generator error
--------------------
Code generator errors are internal errors or target-dependent error.
*/
Static Void code_error_pils(why)
Char *why;
{
printf(" RPCC: **** Error: %.*s\n", error_length, why);
printf(" (Error detected at PILS code generator stage.)\n");
_Escape(0);
}
/*___________________________________________________________________________
Indenting algorithm
*/
Static long ind_pils(level)
long level;
{
return (level * 3);
}
/*___________________________________________________________________________
Append a PILS index to an array expression
Level = 1 => rpc_a used,
Level = 2 => rpc_b used etc...
*/
Static Void append_index_pils(expr, level)
expression *expr;
long level;
{
format(expr, "$(rpc_ ");
append_1(expr, (Char)(level + 96));
append_1(expr, ')');
}
/*___________________________________________________________________________
Generate procedure name to (un)pack a simple type or descriptor
---------------------------------------------------------------
Used for the function return result.
| generates: upk/pck_ttt(rpc_p_buf,
*/
Static Void pack_simple_pils(where, what, topack)
FILE **where;
type_token what;
boolean topack;
{
if (topack)
fprintf(*where, "pck_");
else
fprintf(*where, "upk_");
switch (what) {
case chartok:
fprintf(*where, "char");
break;
case bytetok:
fprintf(*where, "byte");
break;
case shortok:
fprintf(*where, "short");
break;
case integertok:
fprintf(*where, "integer");
break;
case real32tok:
fprintf(*where, "real32");
break;
case real48tok:
fprintf(*where, "real48");
break;
case real64tok:
fprintf(*where, "real64");
break;
case real128tok:
fprintf(*where, "real128");
break;
case longtok:
fprintf(*where, "long");
break;
}
fprintf(*where, "(rpc_p_buf,");
}
/*___________________________________________________________________________
Generate code to: Align on a 2**power byte boundary
Currently, only aligns on word boundaires, because that is all
we need.
*/
Static Void gen_align_pils(power, level)
long power, level;
{
/*gen_align_pils*/
fprintf(op_file, "%*crpc_align(rpc_p_buf,%ld)\n",
(int)ind_pils(level), ' ', power);
/* Extra runtime support needed here */
}
/*___________________________________________________________________________
Generate code to: (un)Pack a parameter of given type
---------------- ----------------------------------
This recursive procedure uses the 'level' parameter to control the
amount of indentation at each stage, and which rpc_<level> parameters
may be accessed by any given stage.
If the type is declared as 'EXTERNAL_MARSHALLING, then an external
procedure pck_<typename> or Upck_<typename> is called to do the
marshalling.
On entry,
Output cursor at left margin.
On exit,
Output cursor at left margin.
*/
Static Void gen_pack_type_pils(where, expr, typ, level, topack)
FILE **where;
expression expr;
defined_type *typ;
long level;
boolean topack;
{
/* output file */
/* Expression for variable */
/* type descriptor */
/* indentation & rpc_<level> */
/* pack or unpack? */
Char ch;
defined_type *element; /* Array element type */
long depth; /* Depth of nesting of array element */
expression exp2, l_expr; /* Expression for the length of a string, etc */
expression s_expr; /* Expression for the start of a substring */
long i; /* Loop index */
id_name *WITH1;
long FORLIM;
defined_type *WITH2;
/*_____________________________________________________________________________
Main block of gen_pack_type_pils
*/
/*gen_pack_type_pils*/
/* Generate a few useful expressions: */
ch = (Char)(level + 96); /*for rpc_a etc */
l_expr = expr; /* x */
prepend_1(&l_expr, '_'); /* _x */
s_expr = l_expr; /* _x */
prepend_1(&l_expr, 'L'); /* L_x */
prepend_1(&s_expr, 'S'); /* S_x */
if (typ->typ_external) {
fprintf(*where, "%*c", (int)ind_pils(level), ' ');
if (topack)
fprintf(*where, "pck_");
else
fprintf(*where, "upk_");
write_name(&op_file, &typ->typ_name->nty_name);
fprintf(*where, "(rpc_p_buf,");
write_exp(where, &expr);
fprintf(*where, ")\n");
return;
}
switch (typ->typ_basic_type) { /*case*/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S I M P L E
Here we assume that the names of the pck/upk routines are consistent
with the names rpc_xxx of the basic types. The exception is the code
for unpacking a character, which is going to be a bit weierd, because
of the descriptor.
*/
case chartok: /*simple type */
fprintf(*where, "%*c", (int)ind_pils(level), ' ');
if (topack)
fprintf(*where, "pck");
else
fprintf(*where, "upk");
fprintf(*where, "_char_PILS(rpc_p_buf,");
write_exp(where, &expr);
fprintf(*where, ")\n");
break;
case bytetok: /*simple type */
fprintf(*where, "%*c", (int)ind_pils(level), ' ');
if (topack)
fprintf(*where, "pck");
else
fprintf(*where, "upk");
fprintf(*where, "_byte_PILS(rpc_p_buf,");
write_exp(where, &expr);
fprintf(*where, ")\n");
break;
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok: /*simple type */
fprintf(*where, "%*c", (int)ind_pils(level), ' ');
if (topack)
fprintf(*where, "pck");
else
fprintf(*where, "upk");
WITH1 = &typ->typ_name->nty_name;
FORLIM = WITH1->len;
for (i = 3; i < FORLIM; i++)
putc(WITH1->str[i], *where);
fprintf(*where, "(rpc_p_buf,");
write_exp(where, &expr);
fprintf(*where, ")\n");
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A R R A Y
Example: FOR rpc_a=1,12
FOR rpc_b=1,10
...myvar(rpc_a,rpc_b)...
ENDFOR
ENDFOR
*/
case arraytok: /*arraytok*/
exp2 = expr;
depth = level;
ch = (Char)(depth + 96);
element = typ->typ_subtype;
format(&exp2, "$(rpc_ ");
append_1(&exp2, ch);
fprintf(*where, "%*c", (int)ind_pils(depth), ' ');
fprintf(*where, "FOR rpc_%c=1 TO %ld\n",
ch, typ->UU.U12.typ_high - typ->UU.U12.typ_low + 1);
while (element->typ_basic_type == arraytok) {
WITH2 = element;
depth++;
ch = (Char)(depth + 96);
fprintf(*where, "%*c", (int)ind_pils(depth), ' ');
fprintf(*where, "FOR rpc_%c=1 TO %ld\n",
ch, WITH2->UU.U12.typ_high - WITH2->UU.U12.typ_low + 1);
format(&exp2, "$,rpc_ ");
append_1(&exp2, ch);
element = element->typ_subtype; /*while*/
}
append_1(&exp2, ')');
gen_pack_type_pils(where, exp2, element, depth + 1, topack);
while (depth >= level) { /*while*/
fprintf(*where, "%*cENDFOR\n", (int)ind_pils(depth), ' ');
depth--; /* Come back out of nesting */
}
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*/
case recordtok: /*recordtok*/
/* R E C O R D */
code_error_pils("No RECORD (STRUCTURE) type exists in PILS! ");
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A C C E S S
*/
case accesstok: /*accesstok*/
code_error_pils("No ACCESS (POINTER) type exists in PILS! ");
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*/
case sequence: /*sequence*/
/* S E Q U E N C E */
if (level > 1)
code_error_pils("SEQUENCE type not allowed within composite type.");
gen_pack_type_pils(where, l_expr,
simple_descriptor[(long)integertok - (long)chartok],
level, topack);
exp2 = expr;
format(&exp2, "A_$ "); /* Make an expression for the array*/
append_index_pils(&exp2, level); /* Make expression for an element */
fprintf(*where, "%*c", (int)ind_pils(level), ' ');
fprintf(*where, "FOR rpc_%c=1 TO L_", ch);
write_exp(where, &expr);
putc('\n', *where);
gen_pack_type_pils(where, exp2, typ->typ_subtype, level + 1, topack);
fprintf(*where, "%*cENDFOR\n", (int)ind_pils(level), ' ');
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*/
case stringtok: /*stringtok*/
/* S T R I N G */
fprintf(*where, "%*c", (int)ind_pils(level), ' ');
if (topack)
fprintf(*where, "pck_string");
else
fprintf(*where, "upk_string");
fprintf(*where, "(rpc_p_buf,");
write_exp(where, &expr);
fprintf(*where, ")\n");
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S U B S T R I N G
*/
case substring: /*substring*/
fprintf(*where, "%*c", (int)ind_pils(level), ' ');
if (topack)
fprintf(*where, "pck_substring");
else
fprintf(*where, "upk_substring");
fprintf(*where, "(rpc_p_buf,A_");
write_exp(where, &expr);
putc(',', *where);
fprintf(*where, "S_");
write_exp(where, &expr);
fprintf(*where, ",L_");
write_exp(where, &expr);
fprintf(*where, ")\n");
break;
}
}
/*___________________________________________________________________________
Generate code to: (un)Pack all parameters necessary
----------------- ---------------------------------
The dirn parameter is INtok or OUTok, to specify which parameters to unpack.
A string descriptor needs to be initialised, including the creation of the
string, at the server side, and the string has to be disposed of afterwards.
*/
Static Void gen_pack_pils(where, head, dirn, topack)
FILE **where;
id_list *head;
type_token dirn;
boolean topack;
{
/* Output file */
/* Parameter list */
/* Parameter filter */
/* Pack, rather than unpack? */
expression expr;
defined_type *WITH1;
do {
WITH1 = head->id_type;
/* generate an expression for the variable: */
expr.len = 0; /* Expression for the variable */
append_name(&expr, head->name); /* expr is the param. name */
/* Pack or unpack
--------------
*/
if (head->attr == inoutok || head->attr == dirn) { /*if*/
deref = (client &&
!(runoptions[(long)byvalue - (long)ccerncross].value &&
head->attr == intok));
/** not value param **/
/* and in-only param */
/*level*/
gen_pack_type_pils(where, expr, head->id_type, 1L, topack);
}
/*with*/
head = head->next;
} while (head != NULL);
} /*gen_pack_pils*/
/* (end of packing/unpacking)
*****************************************************************************
Generate: A type declaration in PILS
This recursive procedure generates a definition of a type, given
a name and a type descriptor. It is impossible to generate a type
itself, as the name is buried within it in PILS.
Examples
CHAR MYSTR(10,2)
for
mystr: ARRAY[1..10, 1..2] OF STRING
On entry,
Cursor is assumed to be at left margin.
On exit,
Cursor is again at the left margin.
*/
Static Void gen_type_decl_pils(expr, pt, level)
expression expr;
defined_type *pt;
long level;
{
/* for the variable */
/* type structure */
/* indentation */
defined_type *scan;
expression exp2;
/*gen_type_decl_pils*/
switch (pt->typ_basic_type) { /*with, case*/
case chartok:
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok: /* First token, simple type, courier type */
/* write(op_file, ' ':ind_pils(level)); */
switch (pt->typ_basic_type) { /*case*/
case chartok:
fprintf(op_file, "int16");
break;
case bytetok:
fprintf(op_file, "int16");
break;
case integertok:
fprintf(op_file, "INT");
break;
case real32tok:
fprintf(op_file, "REAL");
break;
case real48tok:
fprintf(op_file, "REAL");
break;
case real64tok:
fprintf(op_file, "REAL");
break;
case real128tok:
fprintf(op_file, "REAL");
break;
case shortok:
fprintf(op_file, "INT16");
break;
case longtok:
fprintf(op_file, "INT32");
break;
}
putc(' ', op_file);
write_exp(&op_file, &expr); /* Example: rpc_char x */
break;
/*simple type*/
case substring:
case stringtok: /*stringtok*/
/* Example: rpc_char x[81] */
fprintf(op_file, "CHAR ");
write_exp(&op_file, &expr);
break;
/* write(op_file, ' ':ind_pils(level)); */
case sequence:
case arraytok: /*arraytok*/
/* example INT MYARR(10,20) */
exp2 = expr;
append_1(&exp2, '(');
append_decimal(&exp2, pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1);
scan = pt->typ_subtype;
while (scan->typ_basic_type == arraytok) { /*while*/
append_1(&exp2, ',');
append_decimal(&exp2, scan->UU.U12.typ_high - pt->UU.U12.typ_low + 1);
scan = scan->typ_subtype;
}
append_1(&exp2, ')');
gen_type_decl_pils(exp2, scan, level); /*non-array type*/
break;
case accesstok:
code_error_pils("Package has pointers: Can't make PILS stubs. ");
break;
case recordtok:
code_error_pils("Package has records: Can't make PILS stubs. ");
break;
}
}
/*_____________________________________________________________________________
Generate local variables (server) / parameter (client)
------------------------------------------------------
This subroutine will generate
- The parameters to the client subroutine,
- or the local variables in the server.
*/
Static Void gen_params_pils(head)
id_list *head;
{
expression a_expr, l_expr, s_expr, expr;
id_list *scan;
boolean simple_ref; /* Should simple variables be dereferenced? */
boolean composite_ref; /* what about composite variables? */
defined_type *WITH;
scan = head;
if (client)
putc('(', op_file);
while (scan != NULL) { /*while*/
/** Write the parameter attribute **/
if (client) {
switch (scan->attr) { /*CASE*/
case intok:
fprintf(op_file, "IN ");
break;
case outok:
fprintf(op_file, "OUT ");
break;
case inoutok:
fprintf(op_file, "INOUT ");
break;
}
}
WITH = scan->id_type; /*with*/
/** Write the type's name if any otherwise the full declaration **/
/** Sequences and substrings MUST be expanded a little **/
expr.len = 0;
append_name(&expr, scan->name);
l_expr = expr; /* x */
prepend_1(&l_expr, '_'); /* _x */
s_expr = l_expr; /* _x */
a_expr = l_expr; /* _x */
prepend_1(&l_expr, 'L'); /* L_x */
prepend_1(&s_expr, 'S'); /* S_x */
prepend_1(&a_expr, 'A'); /* A_x */
switch (WITH->typ_basic_type) { /*case*/
case chartok:
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok:
case stringtok:
case recordtok:
case arraytok:
gen_type_decl_pils(expr, scan->id_type, 1L);
break;
case sequence: /* a_xxx: tttt; */
gen_type_decl_pils(a_expr, scan->id_type, 1L);
/* l_xxx: rpc_integer */
if (client) /* PILS */
putc(',', op_file); /* PILS */
else
putc(';', op_file);
gen_type_decl_pils(l_expr,
simple_descriptor[(long)integertok - (long)chartok],
1L);
break;
case substring: /* a_xxx: tttt; */
gen_type_decl_pils(a_expr, scan->id_type, 1L);
if (client) /* PILS */
putc(',', op_file); /* PILS */
else
putc(';', op_file);
gen_type_decl_pils(s_expr,
simple_descriptor[(long)integertok - (long)chartok],
1L);
if (client) /* PILS */
putc(',', op_file); /* PILS */
else
putc(';', op_file);
gen_type_decl_pils(l_expr,
simple_descriptor[(long)integertok - (long)chartok],
1L);
break;
}
scan = scan->next;
if (scan == NULL) /* PILS */
break;
if (client)
putc(',', op_file); /* PILS */
else
putc(';', op_file);
}
if (client) /* PILS */
putc(')', op_file);
putc('\n', op_file);
} /*GEN_PARAMS_PILS*/
/*____________________________________________________________________________
Generate Formal Parameter List
*/
Static Void gen_formals(head)
id_list *head;
{
/* Generates the formal parameter list enclosed in brackets (a,b,c,d) */
id_list *scan;
if (head == NULL) /*if list not NIL*/
return;
scan = head;
putc('(', op_file);
while (scan != NULL) { /*while*/
if (((1L << ((long)scan->id_type->typ_basic_type)) &
((1L << ((long)sequence)) | (1L << ((long)substring)))) != 0)
/* p2c: rpcc.p, line 4865: Note:
* Line breaker spent 0.3+1.65 seconds, 142 tries on line 5988 [251] */
fprintf(op_file, "A_");
write_name(&op_file, &scan->name);
if (scan->id_type->typ_basic_type == substring) {
fprintf(op_file, ", S_");
write_name(&op_file, &scan->name);
}
if (((1L << ((long)scan->id_type->typ_basic_type)) &
((1L << ((long)sequence)) | (1L << ((long)substring)))) != 0) {
/* p2c: rpcc.p, line 4865: Note:
* Line breaker spent 0.1+1.09 seconds, 142 tries on line 5998 [251] */
fprintf(op_file, ", L_");
write_name(&op_file, &scan->name);
}
scan = scan->next;
if (scan != NULL)
putc(',', op_file);
}
putc(')', op_file);
} /*gen_formals*/
/*_________________________________________________________________________
Generate: A structure declaration in PILS
==============================================
Example: STRUCTURE /structurename/
CHARACTER*80 fieldname
INTEGER fieldname2
END STRUCTURE
*/
Static Void gen_struct_pils(pt, level)
defined_type *pt;
long level;
{
/* type structure */
/* indentation */
/* writeln(op_file, '!-- Sorry, No PILS Structures !!!'); */
/*gen_struct_pils*/
}
/*___________________________________________________________________________
Generate type definitions for whole package
===========================================
Example:
INT P1
INT P2(3,3)
CHAR P3(10)
*/
Static Void generate_types_pils()
{ /*generate types*/
/* writeln(op_file, '!-- Sorry, No PILS User Defined Types !!!'); */
}
/* Local variables for client_generator_pils: */
struct LOC_client_generator_pils {
long proc_number;
} ;
Local Void gen_client_block_(ptr, LINK)
block_table *ptr;
struct LOC_client_generator_pils *LINK;
{
/****
* On each block, the client allocates 'rpc_integer' variables to pack or
* unpack parameters.
*****/
long a;
expression expr; /* Expression for return value */
long FORLIM;
/* Generate Header:
*/
if (ptr->b_type == functok) {
fprintf(op_file, "DEF ");
switch (ptr->return_) { /*case*/
case chartok:
fprintf(op_file, "int16");
break;
case bytetok:
fprintf(op_file, "int16");
break;
case shortok:
case integertok:
fprintf(op_file, "INT16");
break;
case longtok:
fprintf(op_file, "INT32");
break;
case real32tok:
case real48tok:
case real64tok:
case real128tok:
fprintf(op_file, "REAL");
break;
}
putc(' ', op_file);
write_name(&op_file, &ptr->name);
} else { /*if*/
fprintf(op_file, "SUB ");
write_name(&op_file, &ptr->name);
}
gen_params_pils(ptr->list); /* Generate formal parameter list */
fprintf(op_file, "\n INT rpc_p_buf");
/* Local variables:
*/
FORLIM = ptr->blk_nesting + 96;
for (a = 97; a <= FORLIM; a++)
fprintf(op_file, ",rpc_%c", (Char)a);
putc('\n', op_file);
if (ptr->b_type == functok) /*if*/
{ /* Variable for return value */
fprintf(op_file, " INT rpc_ret\n");
/*
format(expr, 'rpc_ret ');
gen_type_decl_pils(expr, simple_descriptor[return], 1);
*/
}
fprintf(op_file, "\n rpc_begin_call(rpc_p_buf,h_");
/* Code of routine starts here:
*/
write_name(&op_file, &unitname);
fprintf(op_file, ",%ld,%ld,%ld,%ld)\n",
ptr->blk_max_in, ptr->blk_max_out, version_num, LINK->proc_number);
/** generate packing statements for IN & INOUT params **/
if (ptr->list != NULL)
gen_pack_pils(&op_file, ptr->list, intok, true);
/** generate rpc_call and bookeeping **/
if (ptr->blk_cast)
fprintf(op_file, " rpc_cast(h_");
else
fprintf(op_file, " rpc_call(h_");
write_name(&op_file, &unitname);
fprintf(op_file, ",rpc_p_buf");
if (!ptr->blk_cast)
fprintf(op_file, ",%ld", ptr->blk_timeout);
fprintf(op_file, ")\n");
/** if function: unpack return value **/
if (ptr->b_type == functok) { /*if*/
fprintf(op_file, " ");
pack_simple_pils(&op_file, ptr->return_, false);
fprintf(op_file, "rpc_ret)\n");
}
/** generate UNpacking statements for OUT and INOUT params **/
if (ptr->list != NULL)
gen_pack_pils(&op_file, ptr->list, outok, false);
/** clear up everything and exit **/
fprintf(op_file, " rpc_end_call(rpc_p_buf)\n");
if (ptr->b_type == functok) { /*if*/
fprintf(op_file, " ");
write_name(&op_file, &ptr->name);
fprintf(op_file, "=rpc_ret\n"); /* Define function value */
}
fprintf(op_file, "END");
if (ptr->b_type == functok)
fprintf(op_file, "DEF");
else
fprintf(op_file, "SUB");
fprintf(op_file, "\n\n");
/*with*/
} /*gen_client_block*/
Local Void gen_client_header(LINK)
struct LOC_client_generator_pils *LINK;
{
/*
Generates: The CLIENT module header
The constant and type definitions
*/
fprintf(op_file, "!---\n");
fprintf(op_file, "!--- CLIENT STUB routines for package ");
write_name(&op_file, &unitname);
fprintf(op_file, "\n!---\n");
fprintf(op_file, "!--- Generated automatically by the RPC Compiler\n");
fprintf(op_file, "!---\n\n");
fprintf(op_file, "OPTION IMPLICIT OFF\n");
fprintf(op_file, "OPTION BASE 1\n");
fprintf(op_file, "MODULE CLI");
write_name_pils(&op_file, &unitname);
fprintf(op_file, "\n\nGLOBAL INT h_");
write_name_pils(&op_file, &unitname);
fprintf(op_file, "\n\n");
/* generate_externals; */
} /*GEN_CLIENT_HEADER*/
Local Void gen_open_(LINK)
struct LOC_client_generator_pils *LINK;
{
fprintf(op_file, "SUB open_");
write_name_pils(&op_file, &unitname);
fprintf(op_file, "()\n");
fprintf(op_file, " INT status\n");
fprintf(op_file, " CHAR service\n\n");
fprintf(op_file, " service = ");
write_name_padded_pils(&op_file, unitname, '"');
fprintf(op_file, "\n rpc_open(status,h_");
write_name_pils(&op_file, &unitname);
fprintf(op_file, ",service)\n");
fprintf(op_file, " rpc_report_error(status)\n");
fprintf(op_file, "ENDSUB\n\n");
if (runoptions[(long)noautoinit - (long)ccerncross].value)
return;
fprintf(op_file,
"!--- This procedure will be called at initialisation time ***\n");
fprintf(op_file, "open_");
write_name_pils(&op_file, &unitname);
fprintf(op_file, "()\n\n");
} /*GEN_OPEN*/
/*******************************************************************************
Client code generator
=====================
Generates one procedure or function for the client.
*/
Static Void client_generator_pils()
{
struct LOC_client_generator_pils V;
block_table *scan;
gen_client_header(&V);
/** Generate procedures **/
V.proc_number = 1;
scan = blockptr;
while (scan != NULL) {
gen_client_block_(scan, &V);
V.proc_number++;
scan = scan->next;
}
gen_open_(&V);
fprintf(op_file, "ENDMODULE\n");
} /*CLIENT_GEN_pils*/
/* Local variables for server_generator_pils: */
struct LOC_server_generator_pils {
block_table *scan;
} ;
/*_____________________________________________________________________________
Generate server stub for one procedure
*/
Local Void gen_r_routine_(LINK)
struct LOC_server_generator_pils *LINK;
{
long a, b;
/*gen_r_routine*/
fprintf(op_file, "SUB r_");
write_name(&op_file, &LINK->scan->name);
fprintf(op_file, "(INOUT INT rpc_p_buf)\n");
generate_types_pils(); /* Declare structure types */
gen_params_pils(LINK->scan->list); /* Declare types of parameters */
putc('\n', op_file);
b = LINK->scan->blk_nesting;
if (b > 0)
fprintf(op_file, " INT rpc_a");
for (a = 98; a <= b + 96; a++)
fprintf(op_file, ",rpc_%c", (Char)a);
fprintf(op_file, "\n\n");
/* Generate UNpacking statements for IN and INOUT params:
*/
if (LINK->scan->list != NULL)
gen_pack_pils(&op_file, LINK->scan->list, intok, false);
/** generate call and bookeeping **/
fprintf(op_file, " rpc_init_return(rpc_p_buf)\n");
if (LINK->scan->b_type == proctok && LINK->scan->in_only) {
if (runoptions[(long)concurrent - (long)ccerncross].value ||
LINK->scan->blk_concurrent)
fprintf(op_file, " rpc_early_return(rpc_p_buf)\n");
else if (LINK->scan->blk_cast)
fprintf(op_file, " rpc_no_return(rpc_p_buf)\n");
}
/** if function: generate return variable, else just call subroutine.**/
fprintf(op_file, " ");
if (LINK->scan->b_type == functok)
pack_simple_pils(&op_file, LINK->scan->return_, true);
write_name(&op_file, &LINK->scan->name);
gen_formals(LINK->scan->list);
if (LINK->scan->b_type == functok)
putc(')', op_file);
putc('\n', op_file);
/** generate packing statements for OUT and INOUT params**/
if (LINK->scan->list != NULL)
gen_pack_pils(&op_file, LINK->scan->list, outok, true);
fprintf(op_file, "ENDSUB\n\n");
/* Blank line after each one */
}
/*_____________________________________________________________________________*/
/* Generate Code to Attach stub to RPCRTS
--------------------------------------
*/
Local Void gen_attach(LINK)
struct LOC_server_generator_pils *LINK;
{
if (!runoptions[(long)noautoinit - (long)ccerncross].value)
fprintf(op_file, "!--- Call this procedure at initialisation time ***\n");
fprintf(op_file, "SUB attach_");
write_name_pils(&op_file, &unitname);
fprintf(op_file, "()\n");
fprintf(op_file, " INT status\n");
fprintf(op_file, " CHAR service\n\n");
fprintf(op_file, " service = ");
write_name_padded_pils(&op_file, unitname, '"');
fprintf(op_file, "\n rpc_attach_stub(status,address(r_");
write_name_pils(&op_file, &unitname);
fprintf(op_file, "),service,program_number)\n");
fprintf(op_file, " rpc_report_error(status);\n");
fprintf(op_file, "ENDSUB\n\n");
} /*GEN_ATTACH*/
/*_____________________________________________________________________________
Generate Code to Detach stub from RPCRTS
----------------------------------------
*/
Local Void gen_detach(LINK)
struct LOC_server_generator_pils *LINK;
{
if (!runoptions[(long)noautoinit - (long)ccerncross].value)
fprintf(op_file, "!--- Call this procedure at exit time ***\n");
fprintf(op_file, "SUB detach_");
write_name_pils(&op_file, &unitname);
fprintf(op_file, "()\n\n");
fprintf(op_file, " rpc_detach_stub(program_number)\n");
fprintf(op_file, "ENDSUB\n\n");
} /*GEN_DETACH*/
/******************************************************************************
S E R V E R C O D E G E N E R A T O R
*************************************************
*/
Static Void server_generator_pils()
{
struct LOC_server_generator_pils V;
long i; /* Label counter for computed goto */
long proc_num;
/* Generate Main Server Procedure
------------------------------
*/
fprintf(op_file, "!---\n");
fprintf(op_file, "!--- SERVER STUB routines for package ");
write_name(&op_file, &unitname);
fprintf(op_file, "\n!---\n");
fprintf(op_file, "!--- Generated automatically by the RPC Compiler\n");
fprintf(op_file, "!---\n\n");
fprintf(op_file, "OPTION IMPLICIT OFF\n");
fprintf(op_file, "OPTION BASE 1\n");
fprintf(op_file, "MODULE SER");
write_name_pils(&op_file, &unitname);
fprintf(op_file, "\nHIDDEN INT program_number\n\n");
/* Generate individual routines for each procedure:
-----------------------------------------------
*/
V.scan = blockptr;
proc_num = 0;
while (V.scan != NULL) { /*while*/
proc_num++; /* Count the procedures */
gen_r_routine_(&V); /* Generate the individual stub subroutines */
V.scan = V.scan->next;
}
/* Generate the main server stub subroutine:
----------------------------------------
*/
fprintf(op_file, "!---\n");
fprintf(op_file, "!--- Main stub entry point\n");
fprintf(op_file, "!---\n");
fprintf(op_file, "SUB r_");
write_name(&op_file, &unitname);
fprintf(op_file, "(INOUT INT rpc_p_buf)\n");
fprintf(op_file, " INT16 rpc_request\n\n");
fprintf(op_file, " upk_short(rpc_p_buf,rpc_request)\n");
if (version_num != 0) { /*if version number used */
fprintf(op_file, " IF (rpc_request # 0) AND (rpc_request # %ld) THEN\n",
version_num);
fprintf(op_file,
" rpc_set_error(rpc_p_buf,rpc_s_unsupported_version)\n");
fprintf(op_file, " ELSE\n");
}
fprintf(op_file, " upk_short(rpc_p_buf,rpc_request)\n");
fprintf(op_file, " SELECT rpc_request\n");
V.scan = blockptr;
proc_num = 1;
while (V.scan != NULL) {
fprintf(op_file, " CASE %2ld\n", proc_num);
fprintf(op_file, " r_");
write_name_pils(&op_file, &V.scan->name);
fprintf(op_file, "(rpc_p_buf)\n");
proc_num++;
V.scan = V.scan->next;
}
fprintf(op_file, " CASE ELSE \n");
fprintf(op_file, " ");
fprintf(op_file, "rpc_set_error(rpc_p_buf,rpc_s_bad_procedure_number)\n");
fprintf(op_file, " ENDSELECT\n");
if (version_num != 0)
fprintf(op_file, " ENDIF\n");
fprintf(op_file, "ENDSUB\n\n");
/* Generate Code to Attach stub to RPCRTS
--------------------------------------
*/
gen_attach(&V);
gen_detach(&V);
fprintf(op_file, "ENDMODULE\n");
} /*SERVER_GEN_PILS*/
/* CODEGEN
Top-down RPC compiler: Code generator
====================== ==============
History:
3 Jun 1986 Written, Antonio Pastore, Tec.Student 1986, DD/OC, CERN
15 Aug 86 TBL Bug fix in gen_loc_type
18 Aug 86 length follows array param in sequence, like string.
19 Aug 86 VAX strings take descriptor only. New & dispose in.
2 Sep 86 CALL_MESSAGE bug fix -- should be CALL_HEADER_LENGTH
15 Oct 86 CALL_HEADER_LENGTH -2 used, as c_h_l includes proc#.
23 Oct 86 m_index used insted of _count: reentrant code.
Local variables preceded by underline.
Server procedures are all local to main jump procedure
31 Oct 86 rpc_integer type introduced and used for substrings
8 Nov 86 Bug fix in substring handling: packed l-s bytes 61108
17 Dec 86 M6809 addition
6 Jan 87 Bug fix
30 Jan 87 Fixes for M6809; externals inline in client now.
9 Mar 87 Timeout parameter added to rpc_call
20 Mar 87 Rename: pack_xxx -> pck_xxx, unpack_xxx -> upk_xxx
4 Jun 87 handle for 6809 in external, not entry
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.
*/
/*____________________________________________________________________________
Code generator error
--------------------
Code generator errors are internal errors or target-dependent error.
*/
Static Void codegen_error(why)
Char *why;
{
printf(" RPCC: **** Error: %.*s\n", error_length, why);
printf(" (Error detected at code generator stage.)\n");
_Escape(0);
}
/*____________________________________________________________________________
*/
/* Write language elements to file:
-------------------------------
*/
Static Void writok(where, what)
FILE **where;
type_token what;
{
switch (what) {
case chartok:
fprintf(*where, "rpc_char");
break;
case bytetok:
fprintf(*where, "rpc_byte");
break;
case shortok:
fprintf(*where, "rpc_short");
break;
case integertok:
fprintf(*where, "rpc_integer");
break;
case real32tok:
fprintf(*where, "rpc_real32");
break;
case real48tok:
fprintf(*where, "rpc_real48");
break;
case real64tok:
fprintf(*where, "rpc_real64");
break;
case real128tok:
fprintf(*where, "rpc_real128");
break;
case longtok:
fprintf(*where, "rpc_long");
break;
case arraytok:
case sequence:
case stringtok:
case substring:
if (((1L << ((long)omode)) & Cmode) != 0)
putc('[', *where);
else
fprintf(*where, "ARRAY [1..");
break;
case proctok:
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(*where, "PROCEDURE ");
break;
case functok:
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(*where, "FUNCTION ");
break;
}
}
/*___________________________________________________________________________
Indenting algorithm
*/
Static long LeftIn(level)
long level;
{
return (level * 3);
}
/*___________________________________________________________________________
*/
Static Void write_declaration(where, prefix, ptr, ref)
FILE **where;
Char prefix;
id_list *ptr;
boolean ref;
{
defined_type *WITH1;
if (((1L << ((long)omode)) & Cmode) == 0) {
if (ref)
fprintf(*where, "VAR ");
if (prefix != ' ')
fprintf(*where, "%c_", prefix);
write_name(where, &ptr->name);
fprintf(*where, ": ");
}
WITH1 = ptr->id_type;
if (WITH1->typ_name != NULL)
write_name(where, &WITH1->typ_name->nty_name);
else
codegen_error("Internal error: Unnamed type when name needed! ");
if (((1L << ((long)omode)) & Cmode) == 0)
return;
putc(' ', *where);
if (ref)
putc('*', *where);
if (prefix != ' ')
fprintf(*where, "%c_", prefix);
write_name(where, &ptr->name);
}
/*___________________________________________________________________________
Generate: Declatation of an integer
*/
Static Void write_integer(where, prefix, name, ref)
FILE **where;
Char prefix;
id_name *name;
boolean ref;
{
/* output file */
/* Space, or l or s for example */
/* Variable name */
/* Pass by reference? */
fprintf(*where, " ");
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(*where, "rpc_integer ");
if (ref) {
if (((1L << ((long)omode)) & Cmode) != 0)
putc('*', *where);
else
fprintf(*where, "VAR ");
}
if (prefix != ' ')
fprintf(*where, "%c_", prefix);
write_name(where, name);
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(*where, " : rpc_integer");
}
/*___________________________________________________________________________
Find out whether type needs dynamic allocation
----------------------------------------------
This function returns whether a type needs memory allocation performing.
In general, pointer types are dynamic, and composite types are dynamic
if they contain any dynamic types.
The rules applied to pointers depend on the direction of the parameter
and are summarised in the following table.
IN parameters are straightforward, in that they are allocated by the
client, and temporarily reconstructed on the server node by the stub.
For INOUT parameters, the client must ensure that no other pointers are kept
to items in the original tree, as it will be deallocated by the stub. The
server must ensure that any items removed from the tree are returned to the
heap, and any added to the tree are taken from the heap.
For OUT parameters, the client's pointer is overwritten and its original
value lost, without any deallocation of any items to which it may have
pointed. The new tree is allocated by the stub from the heap, and the
client is responsible for eventually deallocating it.
CLIENT SERVER
______ _________________________ ______________________________
IN allocated by client
MARSHALLED
ALLOCATED DURING UNMARSHALLING
untouched by server
DEALLOCATED *
IN OUT allocated by client
MARSHALLED
DEALLOCATED
ALLOCATED DURING UNMARSHALLING
modified by server
MARSHALLED
DEALLOCATED
ALLOCATED DURING UNMARSHALLING
OUT assumed unallocated
set to NIL
allocated by server
MARSHALLED
DEALLOCATED
ALLOCATED DURING UNMARSHALLING
Unmarshalling always implies allocation and vice-versa.
Marshalling implies deallocation EXCEPT for in parameters,
and deallocation has to be done (sometimes) on it's own.
String descriptors contain pointers which are different in that they are
allocated (normally statically) by the client in all cases:
String CLIENT SERVER
descriptors: _________________________ ________________________________
(MARSHALLED)
ALLOCATED *
(UNMARSHALLED)
(MARSHALLED)
DEALLOCATED *
(UNMARSHALLED)
(De)Allocation has to be done independently of [un]marshalling,
in cases marked "*". In this case, a procedure is needed to check a composite
type to see whether it is going to need allocation or deallocation. This is
done by "contains"
____________________________________
Check to see whether given types occur anywhere in a composite type:
*/
Static boolean contains(pt, typeset)
defined_type *pt;
long *typeset;
{
boolean Result;
named_type *scan, *WITH1;
Result = P_inset(pt->typ_basic_type, typeset);
switch (pt->typ_basic_type) { /*case*/
case chartok:
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok:
case substring:
case sequence:
case stringtok: /* ok */
break;
case accesstok:
case arraytok:
if (contains(pt->typ_subtype, typeset))
Result = true;
break;
case recordtok: /*recordtok*/
scan = pt->UU.typ_fields;
while (scan != NULL) {
WITH1 = scan;
if (contains(WITH1->nty_type, typeset))
Result = true;
scan = WITH1->nty_next; /*while*/
}
break;
}
/*with*/
return Result;
} /*contains*/
/*_____________________________________________________________________________
Generate external definitions of external marshalling routines
--------------------------------------------------------------
Should only be called if it is appropriate for the output mode
(Not pcturbo, macturbo)
Example (vaxvms):
|
| procedure upk_mytype(var rpc_p_buf: rpc_message_pointer;
| var param: mytype); external;
| procedure pck_mytype(var rpc_p_buf: rpc_message_pointer;
| param: mytype); external;
*/
Static Void decl_ext_marshal()
{
named_type *pnt;
boolean topack;
/*decl_ext_marshal*/
pnt = typeptr;
while (pnt != NULL) { /*while*/
if (pnt->nty_type->typ_external) {
for (topack = false; topack <= true; topack = (boolean)(topack + 1))
{ /*if for*/
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(op_file, "extern %.3s_", upkpck[topack]);
write_name(&op_file, &pnt->nty_name);
fprintf(op_file, "();\n");
} else {
fprintf(op_file, "procedure %.3s_", upkpck[topack]);
write_name(&op_file, &pnt->nty_name);
fprintf(op_file, "(var rpc_p_buf: rpc_message_pointer;\n");
fprintf(op_file, " ");
if (!topack)
fprintf(op_file, "var ");
fprintf(op_file, "param: ");
write_name(&op_file, &pnt->nty_name);
if (((1L << ((long)omode)) & (1L << ((long)m6809))) != 0)
fprintf(op_file, "); EXTERNAL; \n");
else
fprintf(op_file, "); EXTERN; \n");
} /*if pascal*/
}
}
pnt = pnt->nty_next;
}
}
/*_____________________________________________________________________________
Perform dynamic allocation/deallocation
---------------------------------------
This procedure will allocate and deallocate VMS strings, and it will
DEallocate pointers. It won't allocate pointers (this is done during
unmarshalling);
Note that in the case of an array, we look ahead to see whether the subtype
is going to need allocation, before producing the code to do the loop.
Pascal: new(p); dispose(p);
C: [not handled] free(p);
p = ( t * ) malloc(sizeof(t));
*/
Static Void gen_allocate(where, expr, pt, level, do_alloc, typeset)
FILE **where;
expression expr;
defined_type *pt;
long level;
boolean do_alloc;
long *typeset;
{
/* ... for the variable */
/* nesting so far */
/* T: all, F: deallocate */
/* types to allocate */
named_type *scan;
expression exp2;
Char ch;
named_type *WITH1;
ch = (Char)(level + 96);
switch (pt->typ_basic_type) { /*with, case*/
case chartok:
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok:
case substring: /* First token, simple type, courier type */
break;
/* Last simple type */
/* Do nothing */
/* Pointers are deallocated after having recursively deallocated anything
they point to.
*/
case accesstok:
if (P_inset(pt->typ_basic_type, typeset)) {
if (do_alloc)
codegen_error("Internal: Call GEN_ALLOCATE to allocate pointer");
exp2 = expr;
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(*where, "%*cif (", (int)LeftIn(level), ' ');
write_exp(where, &expr);
fprintf(*where, ") {");
format(&exp2, "(*$) ");
gen_allocate(where, exp2, pt->typ_subtype, level + 1, do_alloc,
typeset);
fprintf(*where, "%*cfree(", (int)LeftIn(level + 1), ' ');
write_exp(where, &expr);
fprintf(*where, ");\n");
fprintf(*where, "%*c} /* end if */\n", (int)LeftIn(level), ' ');
} else { /*pascal*/
fprintf(*where, "%*cif ", (int)LeftIn(level), ' ');
write_exp(where, &expr);
fprintf(*where, " <> NIL then begin\n");
format(&exp2, "$^ ");
gen_allocate(where, exp2, pt->typ_subtype, level + 1, do_alloc,
typeset);
fprintf(*where, "%*cdispose(", (int)LeftIn(level + 1), ' ');
write_exp(where, &expr);
fprintf(*where, "%*c);\n", (int)LeftIn(level + 1), ' ');
fprintf(*where, "%*cend {if};\n", (int)LeftIn(level), ' ');
}
}
break;
case stringtok:
if ((omode == vaxvms) & P_inset(stringtok, typeset)) { /*stringtok*/
if (do_alloc) {
fprintf(*where, " with ");
write_exp(where, &expr);
fprintf(*where,
" do begin new(StrAdr); strlen :=%ld; { Init. string descriptor }\n",
pt->UU.U12.typ_high);
fprintf(*where, " DType := 0; Cont := 0; end;\n"); /*ok?@@@*/
} else {
fprintf(*where, "%*cdispose(", (int)LeftIn(level), ' ');
write_exp(where, &expr);
fprintf(*where, ".StrAdr);\n");
}
}
break;
case arraytok:
if (contains(pt->typ_subtype, typeset)) { /*arraytok*/
exp2 = expr;
append_index(&exp2, level);
fprintf(*where, "%*c", (int)LeftIn(level), ' ');
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(*where, "FOR rpc_%c := %ld TO %ld DO BEGIN\n",
ch, pt->UU.U12.typ_low, pt->UU.U12.typ_high);
else /*if*/
fprintf(*where, "for (rpc_%c = 0; rpc_%c<%ld; rpc_%c++) {",
ch, ch, pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1, ch);
gen_allocate(where, exp2, pt->typ_subtype, level + 1, do_alloc, typeset);
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(*where, "%*c }\n", (int)LeftIn(level), ' ');
else
fprintf(*where, "%*cEND {FOR};\n", (int)LeftIn(level), ' ');
}
break;
case recordtok: /*recordtok*/
scan = pt->UU.typ_fields;
while (scan != NULL) {
WITH1 = scan;
exp2 = expr;
append_1(&exp2, '.');
append_name(&exp2, WITH1->nty_name);
gen_allocate(where, exp2, WITH1->nty_type, level, do_alloc, typeset);
scan = WITH1->nty_next; /*while*/
}
break;
}
} /*gen_allocate*/
/*___________________________________________________________________________
Generate procedure name to (un)pack a simple type or descriptor
---------------------------------------------------------------
Used for the function return result.
| generates: upk/pck_ttt(rpc_p_buf,
*/
Static Void dopack_simple(where, what, topack)
FILE **where;
type_token what;
boolean topack;
{
fprintf(*where, "%.3s_", upkpck[topack]);
switch (what) {
case chartok:
fprintf(*where, "char(");
break;
case bytetok:
fprintf(*where, "byte(");
break;
case shortok:
fprintf(*where, "short(");
break;
case integertok:
fprintf(*where, "integer(");
break;
case real32tok:
fprintf(*where, "real32(");
break;
case real48tok:
fprintf(*where, "real48(");
break;
case real64tok:
fprintf(*where, "real64(");
break;
case real128tok:
fprintf(*where, "real128(");
break;
case longtok:
fprintf(*where, "long(");
break;
}
fprintf(*where, "rpc_p_buf, ");
}
/*___________________________________________________________________________
Generate code to: Align on a 2**power byte boundary
Currently, only aligns on word boundaires, because that is all
we need.
*/
Static Void gen_align(where, power)
FILE **where;
long power;
{
/*gen_align*/
if (power != 1)
codegen_error("Internal error: Gen_align on non-word boundary! ");
if (size_so_far & 1)
size_so_far++;
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(*where, " IF ODD(m_index) THEN m_index:=m_index+1;\n");
else /*if*/
fprintf(*where, " if (rpc_p_buf->m_index%%2) rpc_p_buf->m_index++;\n");
}
Static Void gen_pack_type PP((FILE **where, expression expr,
defined_type *typ, long level, int deref,
int topack, int check_size));
/* Local variables for gen_pack_type: */
struct LOC_gen_pack_type {
FILE **where;
long level;
boolean topack, check_size;
long original_size; /* Max size packed before this call */
boolean check_subtypes; /* 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.
*/
Local Void gen_pack_string(where, expr, pt, level, topack, LINK)
FILE **where;
expression expr;
defined_type *pt;
long level;
boolean topack;
struct LOC_gen_pack_type *LINK;
{
/* string variable name */
/* data type */
/* indentation level */
/* pack or unpack? */
Char index_a, index_b; /* last character of name of index */
expression a_expr; /* One element of the string */
expression i_expr; /* The integer value of the length */
expression l_expr; /* Expression for the length variable */
/*gen_pack_string*/
index_a = (Char)(level + 96); /* rpc_a etc */
index_b = (Char)(level + 'a'); /* rpc_b etc */
if (((1L << ((long)omode)) & Cmode) != 0) {
a_expr = expr;
append_index(&a_expr, level); /* eg x[rpc_a] */
format(&l_expr, "rpc_ "); /* the length */
append_1(&l_expr, index_b); /* eg rpc_b */
/* Find length of string: */
if (topack) { /* Don't dereference locals */
fprintf(*where, "%*cfor (rpc_%c = 0; rpc_%c <= %ld; rpc_%c++)\n",
(int)LeftIn(level), ' ', index_b, index_b, pt->UU.U12.typ_high,
index_b);
fprintf(*where, "%*cif (", (int)LeftIn(level), ' ');
write_exp(where, &expr);
fprintf(*where, "[rpc_%c] == '\\0') break;\n", index_b);
}
/* (un)pack the length of the string :
*/
/* p2c: rpcc.p, line 5910:
* Note: Line breaker spent 0.2+1.59 seconds, 46 tries on line 7108 [251] */
gen_pack_type(where, l_expr,
simple_descriptor[(long)integertok - (long)chartok], level,
false, topack, LINK->check_subtypes);
/* a := 0 to b */
/* Generate the for loop:
*/
fprintf(*where, "%*cfor (rpc_%c = 0; rpc_%c < rpc_%c; rpc_%c++) {\n",
(int)LeftIn(level), ' ', index_a, index_a, index_b, index_a);
/*deref*/
/* Pack each character:
*/
gen_pack_type(where, a_expr, simple_descriptor[0], level, false, topack,
LINK->check_subtypes);
/* Terminate the for loop:
*/
fprintf(*where, "%*c}\n", (int)LeftIn(level), ' ');
/* Add the terminator in memory:
*/
if (!topack) {
fprintf(*where, "%*c", (int)LeftIn(level), ' ');
write_exp(where, &expr);
fprintf(*where, "[rpc_%c] = '\\0';\n", index_b);
}
size_so_far = LINK->original_size + pt->typ_max_size;
return;
}
/* VAX/VMS descriptors are handled by a subroutine:
*/
if (omode == vaxvms) {
fprintf(*where, "%*c%.3s", (int)LeftIn(level), ' ', upkpck[topack]);
if (!client && !topack)
fprintf(*where, "_Vstring_for(rpc_p_buf, "); /*server unpck */
else
fprintf(*where, "_string_for(rpc_p_buf, ");
write_exp(where, &expr);
fprintf(*where, "::rpc_string_descriptor"); /* Standard Descriptor */
if (!client && !topack) /* Max size */
fprintf(*where, ", %ld", pt->UU.U12.typ_high);
fprintf(*where, ");\n");
/* Generate expressions for the length of the string:
*/
} else { /*if not VAXVMS pascal */
l_expr = expr; /* The name of the length variable */
i_expr = expr; /* The integer value of the length */
a_expr = expr; /* The array containing the string */
if (((1L << ((long)omode)) & ((1L << ((long)m6809)) |
(1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0) {
/* p2c: rpcc.p, line 6430: Note:
* Line breaker spent 0.5+25.76 seconds, 366 tries on line 7253 [251] */
format(&l_expr, "$[0] ");
format(&i_expr, "ord($[0]) ");
} else if (omode == vaxpas) {
format(&l_expr, "$.length ");
i_expr = l_expr; /* The expression already is an integer */
} else {
format(&l_expr, "l_$ ");
format(&a_expr, "a_$ ");
i_expr = l_expr; /* The expression already is an integer */
if (level != 1)
codegen_error("String in composite type illegal for this target");
}
append_index(&a_expr, level); /* a_expr now refers to one element */
/* (un)pack the length of the string :
It's a little unusual for the M6809 etc as the length is of type
character.
*/
fprintf(*where, " ");
if (((1L << ((long)omode)) & ((1L << ((long)m6809)) |
(1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0) {
/* p2c: rpcc.p, line 6430: Note:
* Line breaker spent 2.7+4.64 seconds, 370 tries on line 7277 [251] */
if (topack)
gen_pack_type(where, i_expr,
simple_descriptor[(long)integertok - (long)chartok],
level + 2, false, topack, LINK->check_subtypes);
/* p2c: rpcc.p, line 6430:
* Note: Line breaker spent 0.0+1.28 seconds, 62 tries on line 7283 [251] */
else {
fprintf(*where, "%*c", (int)LeftIn(level), ' ');
write_exp(where, &l_expr);
fprintf(*where, " := rpc_ch[m_index + 1];\n");
fprintf(*where, "%*c", (int)LeftIn(level), ' ');
fprintf(*where, "m_index := (m_index + 2);");
}
} else {
if (omode == vaxpas) /* string length is short */
gen_pack_type(where, l_expr,
simple_descriptor[(long)shortok - (long)chartok],
level + 2, false, topack, LINK->check_subtypes);
else /*deref*/
gen_pack_type(where, l_expr,
simple_descriptor[(long)integertok - (long)chartok],
level + 2, false, topack, LINK->check_subtypes);
/*deref*/
}
/* Generate the FOR loop:
*/
fprintf(*where, "%*cFOR rpc_%c := 1 TO ",
(int)LeftIn(level), ' ', index_a);
write_exp(where, &i_expr);
fprintf(*where, " DO BEGIN\n"); /*deref*/
/* Generate the code to (un)pack the character
*/
gen_pack_type(where, a_expr, simple_descriptor[0], level + 2, false,
topack, LINK->check_subtypes);
/* Terminate the FOR loop:
*/
fprintf(*where, "%*cEND {for \n", (int)LeftIn(level), ' ');
write_exp(where, &i_expr);
fprintf(*where, "};\n");
}
size_so_far = LINK->original_size + pt->typ_max_size;
/*not C -- Pascal: - - - - - - - - - - - - - - - - - - - - -*/
/*if*/
/*if not C */
}
/* 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.
*/
Local Void check_buffer_overflow(allowance, LINK)
long allowance;
struct LOC_gen_pack_type *LINK;
{
if (!(LINK->check_size && size_so_far + allowance > NON_FRAGMENTATION_LIMIT))
return;
if (allowance > FRAGMENTATION_THRESHOLD) /* if*/
return;
fragmentation_used = true;
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(*LINK->where,
"%*cif (rpc_p_buf->m_index > RPC_BUFFER_SIZE - %ld) (void)rpc_",
(int)(LeftIn(LINK->level) + 4), ' ', allowance);
if (LINK->topack)
fprintf(*LINK->where, "put(&rpc_p_buf);\n");
else
fprintf(*LINK->where, "get(&rpc_p_buf);\n");
return;
}
fprintf(*LINK->where,
"%*cif (rpc_p_buf^.m_index > RPC_BUFFER_SIZE - %ld) then rpc_",
(int)(LeftIn(LINK->level) + 4), ' ', allowance);
if (LINK->topack)
fprintf(*LINK->where, "put(rpc_p_buf);\n");
else
fprintf(*LINK->where, "get(rpc_p_buf);\n");
/*pascal*/
}
/*___________________________________________________________________________
Generate code to: (un)Pack a parameter of given type
---------------- ----------------------------------
This recursive procedure uses the 'level' parameter to control the
amount of indentation at each stage, and which rpc_<level> parameters
may be accessed by any given stage.
On entry,
Output cursor at left margin.
On exit,
Output cursor at left margin.
*/
Static Void gen_pack_type(where_, expr, typ, level_, deref, topack_,
check_size_)
FILE **where_;
expression expr;
defined_type *typ;
long level_;
boolean deref, topack_, check_size_;
{
/* output file */
/* Expression for variable */
/* type descriptor */
/* indentation & rpc_<level> */
/* Dereference simple types? */
/* pack or unpack? */
/* check for buffer overflow? */
struct LOC_gen_pack_type V;
Char ch;
named_type *scan;
expression exp2, l_expr; /* Expression for the length of a string, etc */
expression s_expr; /* Expression for the start of a substring */
long i; /* Loop index */
id_name *WITH1;
long FORLIM;
named_type *WITH2;
/*_____________________________________________________________________________
Main block of gen_pack_type
*/
/*gen_pack_type*/
V.where = where_;
V.level = level_;
V.topack = topack_;
V.check_size = check_size_;
V.original_size = size_so_far; /* We will update it */
/* Generate a few useful expressions: */
ch = (Char)(V.level + 96); /*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:
*/
if (typ->typ_external) {
fprintf(*V.where, "%*c%.3s_", (int)LeftIn(V.level), ' ', upkpck[V.topack]);
write_name(&op_file, &typ->typ_name->nty_name);
fprintf(*V.where, "(rpc_p_buf,");
if (((1L << ((long)omode)) & Cmode) != 0 && !V.topack)
putc('&', *V.where);
write_exp(V.where, &expr);
fprintf(*V.where, ");\n");
return;
}
V.check_subtypes = (V.check_size &&
size_so_far + typ->typ_max_size > NON_FRAGMENTATION_LIMIT &&
typ->typ_max_size > FRAGMENTATION_THRESHOLD);
check_buffer_overflow(typ->typ_max_size, &V);
switch (typ->typ_basic_type) { /*case*/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S I M P L E
Here we assume that the names of the pck/upk routines are consistent
with the names rpc_xxx of the basic types.
Note that in Pascal, a character has to be unpacked with an assignment
statement, because the expression can be for a component of a packed array,
which cannot be passed by address. If the expression does not end with ']',
we can go ahead and use upk_char, as it is not an array compenent at all.
In general, we prefer to call upk_char as it may be faster, and is certainly
shorter.
*/
case chartok:
if (((1L << ((long)omode)) & Cmode) != 0 || V.topack ||
expr.str[expr.len - 1] != ']') {
fprintf(*V.where, "%*c%.3s_char(rpc_p_buf, ",
(int)LeftIn(V.level), ' ', upkpck[V.topack]);
if (V.level == 1 && deref && ((1L << ((long)omode)) & Cmode) != 0)
putc('*', *V.where);
write_exp(V.where, &expr);
fprintf(*V.where, ");\n");
} else { /*pascal unpack*/
fprintf(*V.where, "%*cBEGIN\n", (int)LeftIn(V.level), ' ');
fprintf(*V.where, "%*c", (int)(LeftIn(V.level) + 4), ' ');
write_exp(V.where, &expr);
fprintf(*V.where, ":=rpc_ch[m_index];\n");
fprintf(*V.where, "%*cm_index := m_index+1;\n",
(int)(LeftIn(V.level) + 4), ' ');
fprintf(*V.where, "%*cEND;\n", (int)LeftIn(V.level), ' ');
}
size_so_far++;
break;
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok: /*simple type */
fprintf(*V.where, "%*c%.3s", (int)LeftIn(V.level), ' ', upkpck[V.topack]);
WITH1 = &typ->typ_name->nty_name; /* eg "_integer" */
FORLIM = WITH1->len;
for (i = 3; i < FORLIM; i++)
putc(WITH1->str[i], *V.where);
fprintf(*V.where, "(rpc_p_buf, ");
if (V.level == 1 && deref && ((1L << ((long)omode)) & Cmode) != 0)
putc('*', *V.where);
write_exp(V.where, &expr);
fprintf(*V.where, ");\n");
switch (typ->typ_basic_type) {
case bytetok:
size_so_far++;
break;
case shortok:
case integertok:
size_so_far += 2;
break;
case real32tok:
case longtok:
size_so_far += 4;
break;
case real48tok:
size_so_far += 6;
break;
case real64tok:
size_so_far += 8;
break;
case real128tok:
size_so_far += 16;
break;
}
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*/
case arraytok: /*arraytok*/
/* A R R A Y */
exp2 = expr;
append_index(&exp2, V.level);
fprintf(*V.where, "%*c", (int)LeftIn(V.level), ' ');
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(*V.where, "FOR rpc_%c := %ld TO %ld DO BEGIN\n",
ch, typ->UU.U12.typ_low, typ->UU.U12.typ_high);
else /*if*/
fprintf(*V.where, "for (rpc_%c = 0; rpc_%c<%ld; rpc_%c++) {\n",
ch, ch, typ->UU.U12.typ_high - typ->UU.U12.typ_low + 1, ch);
/* 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 = V.original_size + typ->typ_max_size; /*deref*/
gen_pack_type(V.where, exp2, typ->typ_subtype, V.level + 1, false,
V.topack, V.check_subtypes);
size_so_far = V.original_size + typ->typ_max_size;
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(*V.where, "%*c}\n", (int)LeftIn(V.level), ' ');
else
fprintf(*V.where, "%*cEND {FOR};\n", (int)LeftIn(V.level), ' ');
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
R E C O R D
In C, records must be passed by pointers, just like scalar variables, if
they are OUT or INOUT, or the option /BYVALUE is not selected.
*/
case recordtok: /*recordtok*/
scan = typ->UU.typ_fields;
while (scan != NULL) {
WITH2 = scan;
exp2 = expr;
if (V.level == 1 && deref && ((1L << ((long)omode)) & Cmode) != 0)
format(&exp2, "$-> ");
else
format(&exp2, "$. ");
append_name(&exp2, WITH2->nty_name);
gen_pack_type(V.where, exp2, WITH2->nty_type, V.level, false, V.topack,
V.check_subtypes);
scan = WITH2->nty_next; /*while*/
}
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A C C E S S
A pointer is marshalled as a single byte (0 or 1) to say whether the
original pointer was NIL (0) or valid (1). If and only if it was valid,
the byte is followed by the marshalled data which the pointer pointed to.
Allocation is always done on unmarshalling (if the pointer is not NIL).
Deallocation is not done here, but by the gen_allocate routine.
Examples: PASCAL C ([]should be curly)
|
| if x = NIL then pck_byte(0) if (x==NULL) pck_byte(0)
| else begin else [
| pck_byte(1); pck_byte(1);
| ... ...*/
/* p2c: rpcc.p, line 6237: Note: Changed "* /" to "% /" in comment [140]
| end; ] /* end if %/
*/
case accesstok: /*accesstok*/
if (V.check_subtypes) /* Check we aren't on the end */
check_buffer_overflow(1L, &V);
size_so_far++; /* For flag */
if (((1L << ((long)omode)) & Cmode) != 0) {
exp2 = expr;
format(&exp2, "*($) ");
if (!V.topack) { /*if unpack*/
fprintf(*V.where, "%*c", (int)LeftIn(V.level), ' ');
fprintf(*V.where, "if (next_byte(rpc_p_buf)) {\n");
/* Allocate space:
*/
fprintf(*V.where, "%*c", (int)LeftIn(V.level + 1), ' ');
write_exp(V.where, &expr);
if (typ->typ_subtype->typ_name == NULL)
codegen_error("Pointer to unnamed type - cannot allocate space!");
fprintf(*V.where, " = (");
write_name(V.where, &typ->typ_subtype->typ_name->nty_name);
fprintf(*V.where, "*) malloc(sizeof(");
write_name(V.where, &typ->typ_subtype->typ_name->nty_name);
fprintf(*V.where, "));\n");
} else { /*pack*/
fprintf(*V.where, "%*cif (", (int)LeftIn(V.level), ' ');
write_exp(V.where, &expr);
fprintf(*V.where, "==NULL) pck_byte(0);\n");
fprintf(*V.where, "%*celse {\n", (int)LeftIn(V.level), ' ');
fprintf(*V.where, "%*cpck_byte(1);\n", (int)LeftIn(V.level + 1), ' ');
}
/* If the pointer was NULL, skip the lot:
*/
gen_pack_type(V.where, exp2, typ->typ_subtype, V.level, false, V.topack,
V.check_subtypes);
fprintf(*V.where, "%*c} /* end if */\n", (int)LeftIn(V.level), ' ');
} else { /*Pascal*/
exp2 = expr;
append_1(&exp2, '^'); /* x^ */
if (!V.topack) {
fprintf(*V.where, "m_index:=m_index+1;\n");
fprintf(*V.where, "%*cif b[m_index-1]<>0 then begin\n",
(int)LeftIn(V.level), ' ');
/* Allocate space:
*/
fprintf(*V.where, "%*cnew(", (int)LeftIn(V.level + 1), ' ');
write_exp(V.where, &expr);
fprintf(*V.where, ");\n");
} else /*if topack*/
{ /*if topack*/
fprintf(*V.where, "%*cif ", (int)LeftIn(V.level), ' ');
write_exp(V.where, &expr);
fprintf(*V.where, " = NIL then pck_byte(0)\n");
fprintf(*V.where, "%*celse begin\n", (int)LeftIn(V.level), ' ');
fprintf(*V.where, "%*cpck_byte(1);\n", (int)LeftIn(V.level + 1), ' ');
}
/* If the pointer was NIL, skip the lot:
*/
gen_pack_type(V.where, exp2, typ->typ_subtype, V.level, false, V.topack,
V.check_subtypes);
fprintf(*V.where, "%*cend {if};\n", (int)LeftIn(V.level), ' ');
} /*if Pascal*/
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*/
case sequence: /*sequence*/
/* S E Q U E N C E */
if (V.level > 1)
codegen_error("SEQUENCE type not allowed within composite type.");
gen_pack_type(V.where, l_expr,
simple_descriptor[(long)integertok - (long)chartok],
V.level, deref, V.topack, V.check_subtypes);
exp2 = expr;
format(&exp2, "a_$ "); /* Make an expression for the array*/
append_index(&exp2, V.level); /* Make expression for an element */
fprintf(*V.where, "%*c", (int)LeftIn(V.level), ' ');
if (((1L << ((long)omode)) & Cmode) == 0) {
fprintf(*V.where, "FOR rpc_%c := 1 TO l_", ch);
write_exp(V.where, &expr);
fprintf(*V.where, " DO BEGIN\n");
} else { /*if*/
fprintf(*V.where, "for (rpc_%c = 0; rpc_%c< ", ch, ch);
if (deref && ((1L << ((long)omode)) & Cmode) != 0)
putc('*', *V.where);
write_exp(V.where, &l_expr);
fprintf(*V.where, "; rpc_%c++) {\n", ch);
}
size_so_far = V.original_size + typ->typ_max_size;
/* See comment for array */
/*deref*/
gen_pack_type(V.where, exp2, typ->typ_subtype, V.level + 1, false,
V.topack, V.check_subtypes);
size_so_far = V.original_size + typ->typ_max_size;
/* See comment for array */
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(*V.where, "%*c }\n", (int)LeftIn(V.level), ' ');
else
fprintf(*V.where, "%*cEND {FOR};\n", (int)LeftIn(V.level), ' ');
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*/
case stringtok: /*stringtok*/
/* S T R I N G */
gen_pack_string(V.where, expr, typ, V.level, V.topack, &V);
gen_align(V.where, 1L); /* Align on word boundary */
break;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
| S U B S T R I N G
| Example: upk/pck_integer(s_xxx);
| upk/pck_integer(l_xxx);
| FOR rpc_a := s_xxx TO s_xxx + l_xxx - 1 DO
| upk/pck_integer(rpc_p_buf, a_xxx[rpc_a]);
|
| Note: in C, the start address in the string used to run in the range 0..n-1,
| while is Pascal it runs in the range 1..n. The cannonical form for
| transmission involves it running from 1..n, so it was adjusted in the
| C code. This was changed (7-Jun-89) so that it is always passed 1..n.
*/
case substring: /*substring*/
exp2 = s_expr; /* Start Position In String */
gen_pack_type(V.where, exp2,
simple_descriptor[(long)integertok - (long)chartok],
V.level, deref, V.topack, V.check_subtypes);
gen_pack_type(V.where, l_expr,
simple_descriptor[(long)integertok - (long)chartok],
V.level, deref, V.topack, V.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 (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(*V.where, " for (rpc_%c = ", ch);
if (deref)
putc('*', *V.where);
write_exp(V.where, &s_expr);
fprintf(*V.where, "-1; rpc_%c < ", ch);
if (deref)
putc('*', *V.where);
write_exp(V.where, &l_expr);
fprintf(*V.where, " + ");
if (deref)
putc('*', *V.where);
write_exp(V.where, &s_expr);
fprintf(*V.where, "-1; rpc_%c++) {\n", ch);
} else {
fprintf(*V.where, " FOR rpc_%c := ", ch);
write_exp(V.where, &s_expr);
fprintf(*V.where, " TO ");
write_exp(V.where, &l_expr);
putc('+', *V.where);
write_exp(V.where, &s_expr);
fprintf(*V.where, " - 1 DO BEGIN\n");
}
exp2 = expr; /* x */
prepend_1(&exp2, '_'); /* _x */
prepend_1(&exp2, 'a'); /* a_x */
append_index(&exp2, V.level); /* a_x[rpc_a] */
size_so_far = V.original_size + typ->typ_max_size; /*deref*/
gen_pack_type(V.where, exp2, simple_descriptor[0], V.level + 1, false,
V.topack, V.check_subtypes);
size_so_far = V.original_size + typ->typ_max_size;
if (((1L << ((long)omode)) & Cmode) != 0) /* Terminate the loop */
fprintf(*V.where, " }\n");
else
fprintf(*V.where, " END;\n");
gen_align(V.where, 1L); /* Align on word boundary */
break;
}
/*if not external 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.
*/
Static Void gen_pack(where, head, dirn, topack)
FILE **where;
id_list *head;
type_token dirn;
boolean topack;
{
/* Output file */
/* Parameter list */
/* Parameter filter */
/* Pack, rather than unpack? */
expression expr;
defined_type *WITH1;
long SET[3], SET1[3];
do {
WITH1 = head->id_type;
/* generate an expression for the variable: */
expr.len = 0; /* Expression for the variable */
append_name(&expr, head->name); /* expr is the param. name */
/* Initialise any VMS descriptors on server side
------------------------------------------
*/
if (!client && !topack && omode == vaxvms) {
if (contains(head->id_type, P_expset(SET, 1L << ((long)stringtok))))
/*allocate*/
gen_allocate(where, expr, head->id_type, 1L, true,
P_expset(SET1, 1L << ((long)stringtok)));
}
/* Pack or unpack
--------------
*/
if (head->attr == inoutok || head->attr == dirn) { /*if*/
deref = (client &&
!(runoptions[(long)byvalue - (long)ccerncross].value &&
head->attr == intok));
/** not value param **/
/* and in-only param */
/*level*/
/*check for overflow*/
gen_pack_type(where, expr, head->id_type, 1L, deref, topack, true);
}
/* Deallocate Memory
-----------------
*/
if (!client && topack) { /* ie end of server */
if (omode == vaxvms) {
if (contains(head->id_type, P_expset(SET,
(1L << ((long)stringtok)) | (1L << ((long)accesstok)))))
/*deallocate*/
gen_allocate(where, expr, head->id_type, 1L, false,
P_expset(SET1,
(1L << ((long)stringtok)) | (1L << ((long)accesstok))));
/* p2c: rpcc.p, line 6512: Note:
* Line breaker spent 6.4+1.85 seconds, 2968 tries on line 7906 [251] */
} else { /*not vms*/
if (contains(head->id_type, P_expset(SET, 1L << ((long)accesstok))))
/*deallocate*/
gen_allocate(where, expr, head->id_type, 1L, false,
P_expset(SET1, 1L << ((long)accesstok)));
}
}
/* Remove client's tree for an IN OUT parameter */
if (client && head->attr == inoutok && topack) { /*with*/
if (contains(head->id_type, P_expset(SET, 1L << ((long)accesstok))))
/*deallocate*/
gen_allocate(where, expr, head->id_type, 1L, false,
P_expset(SET1, 1L << ((long)accesstok)));
}
head = head->next;
} while (head != NULL);
} /*GEN_PACK*/
/* Local variables for gen_header: */
struct LOC_gen_header {
FILE **where;
boolean doing_externals;
} ;
Local Void gen_formals_c(head, LINK)
id_list *head;
struct LOC_gen_header *LINK;
{
/* Generates the formal parameter list enclosed in brackets */
long a;
id_list *scan;
/** We are sure that head is NOT nil **/
a = 0;
scan = head;
putc('(', *LINK->where);
while (scan != NULL) { /*while*/
if (((1L << ((long)scan->id_type->typ_basic_type)) &
((1L << ((long)sequence)) | (1L << ((long)substring)))) != 0)
/* p2c: rpcc.p, line 6786: Note:
* Line breaker spent 0.1+1.11 seconds, 142 tries on line 7957 [251] */
fprintf(*LINK->where, "a_");
write_name(LINK->where, &scan->name);
if (scan->id_type->typ_basic_type == substring) {
fprintf(*LINK->where, ", s_");
write_name(LINK->where, &scan->name);
a++;
}
if (((1L << ((long)scan->id_type->typ_basic_type)) &
((1L << ((long)sequence)) | (1L << ((long)substring)))) != 0) {
/* p2c: rpcc.p, line 6786: Note:
* Line breaker spent 0.5+1.59 seconds, 142 tries on line 7968 [251] */
fprintf(*LINK->where, ", l_");
write_name(LINK->where, &scan->name);
a++;
}
scan = scan->next;
if (scan == NULL)
break;
fprintf(*LINK->where, ", ");
a++;
if (a > 3) {
a = 0;
fprintf(*LINK->where, "\n ");
}
}
fprintf(*LINK->where, ")\n");
} /*gen_formals_c*/
/*____________________________________
*/
Local Void gen_params(head, LINK)
id_list *head;
struct LOC_gen_header *LINK;
{
/* Generates the parameter list enclosed in brackets,
or VAR followed by list
On entry,
head must not be NIL, must point to list of ids.
*/
id_list *scan;
boolean simple_ref; /* Should simple variables be dereferenced? */
boolean array_deref; /* what about composite variables? */
defined_type *WITH;
/** We are sure that head is NOT nil **/
scan = head;
do {
fprintf(*LINK->where, " ");
/** Write the type's name if any otherwise the full declaration **/
/** Sequences and substrings MUST be expanded a little **/
/** The var's name depends on its type, so be careful! **/
/* Array variables are not dereferenced in C because they are always
passed by address anyway. In Pascal, the VAR is not needed in the
server list, but needed everywhere else.
*/
array_deref = ((client || LINK->doing_externals) &&
((1L << ((long)omode)) & Cmode) == 0);
/* Simple types and structures must be dereferenced unless /BYVALUE was
specified and they are IN.
The VAR is never needed for the list of variables in the server.
*/
simple_ref = ((client || LINK->doing_externals) &&
!(runoptions[(long)byvalue - (long)ccerncross].value &&
scan->attr == intok));
/* ie not server list */
WITH = scan->id_type;
switch (WITH->typ_basic_type) {
case chartok:
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok:
case recordtok:
case accesstok: /* xxxx : tttt */
write_declaration(LINK->where, ' ', scan, simple_ref);
break;
case arraytok: /* xxxx : tttt */
write_declaration(LINK->where, ' ', scan, array_deref);
break;
case stringtok: /* (a_)xxx: tttt(;) */
if (((1L << ((long)omode)) & (Cmode | (1L << ((long)vaxvms)) |
(1L << ((long)vaxpas)) | (1L << ((long)m6809)) |
(1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) == 0) {
/* p2c: rpcc.p, line 6786: Note:
* Line breaker spent 2.1+1.00 seconds, 1222 tries on line 8060 [251] */
write_declaration(LINK->where, 'a', scan, array_deref);
fprintf(*LINK->where, ";\n"); /* (l_xxx: rpc_integer) */
write_integer(LINK->where, 'l', &scan->name, simple_ref);
} else
write_declaration(LINK->where, ' ', scan, array_deref);
break;
case sequence: /* a_xxx: tttt; */
write_declaration(LINK->where, 'a', scan, array_deref);
fprintf(*LINK->where, ";\n");
/* l_xxx: rpc_integer */
write_integer(LINK->where, 'l', &scan->name, simple_ref);
break;
case substring: /* a_xxx: tttt; */
write_declaration(LINK->where, 'a', scan, array_deref);
fprintf(*LINK->where, ";\n");
/* s_xxx: rpc_integer */
write_integer(LINK->where, 's', &scan->name, simple_ref);
fprintf(*LINK->where, ";\n");
/* l_xxx: rpc_integer */
write_integer(LINK->where, 'l', &scan->name, simple_ref);
break;
}/*with, case*/
scan = scan->next;
if (scan != NULL)
fprintf(*LINK->where, ";\n");
} while (scan != NULL);
} /*GEN_PARAMS*/
/* (end of packing/unpacking)
*****************************************************************************
*/
/* Generate local variables (server) / parameter (client)
------------------------------------------------------
This subroutine will generate
- The parameters to the client subroutine,
- or a procedure definition for a turbopascal INTERFACE
- or the local variables in the server.
It is a bit of a mess at present, with the same routine trying to do
many different things. It is currently called in eight different circumstances:
Params C D P
from Server Pascal y F F T
C y F F T
from gen_external )
from gen_module ) Pascal y F T T
from gen_server_block )
or from gen_external ) C y F T T
from extern_gen )
Client INTERFACE section Turbopascal only y T F T
Client routines definition Pascal, except y T F T
Turbopascal n T F F
C y T F T
where C=client(global flag), D=doing_externals, P=Parameters_wanted.
Unfortunately, any rearrangement of the code is likely to be just as messy.
______________________________________________________________________________
*/
Static Void gen_header(where_, ptr, doing_externals_, parameters_wanted)
FILE **where_;
block_table *ptr;
boolean doing_externals_, parameters_wanted;
{
/* Making ext. declarations? */
/*____________________________________
*/
struct LOC_gen_header V;
/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*/
V.where = where_;
V.doing_externals = doing_externals_;
if (((1L << ((long)omode)) & Cmode) != 0) { /* C language */
if (client) {
if (ptr->b_type == functok) { /*function*/
writok(V.where, ptr->return_); /* eg: int xxx(a,b,c) */
putc(' ', *V.where);
}
write_name(V.where, &ptr->name);
gen_formals_c(ptr->list, &V); /* Generate formal parameter list */
} else { /* C server or externals */
if (!V.doing_externals)
fprintf(*V.where, "r_");
write_name(V.where, &ptr->name);
fprintf(*V.where, "()");
if (V.doing_externals) {
fprintf(*V.where, ";\n");
fprintf(*V.where, "/* Parameters: ");
if (ptr->list == NULL)
fprintf(*V.where, "none");
}
putc('\n', *V.where);
if (!V.doing_externals)
fprintf(*V.where, "{\n");
} /*if not client*/
} else /*Pascal*/
{ /* Pascal */
if (client || V.doing_externals) {
writok(V.where, ptr->b_type);
write_name(V.where, &ptr->name);
} else /*server*/
{ /* Pascal server */
writok(V.where, proctok);
if (!V.doing_externals)
fprintf(*V.where, "r_");
write_name(V.where, &ptr->name);
if (!V.doing_externals)
fprintf(*V.where, ";\n");
}
}
/** PRINT PARAMETER LIST if necessary**/
if (parameters_wanted) {
if (ptr->list != NULL) {
if (((1L << ((long)omode)) & Cmode) == 0) {
if (client || V.doing_externals)
fprintf(*V.where, "(\n");
else
fprintf(*V.where, "VAR\n");
}
gen_params(ptr->list, &V);
if ((client || V.doing_externals) &&
((1L << ((long)omode)) & Cmode) == 0)
putc(')', *V.where);
}
}
/** else
if client and (omode in Cmode) then write(where,'()'); **/
/** PRINT RESULT only for client PASCAL functions **/
if (((1L << ((long)omode)) & Cmode) == 0) { /*if Pascal*/
if (client || V.doing_externals) {
if (parameters_wanted && ptr->b_type == functok) {
fprintf(*V.where, ": ");
writok(V.where, ptr->return_);
}
} /*if client */
}
if ((client || V.doing_externals) && ((1L << ((long)omode)) & Cmode) == 0 ||
ptr->list != NULL)
/*end_with*/
fprintf(*V.where, ";\n");
} /*GEN_HEADER*/
/*___________________________________________________________________________
Generate externals
------------------
Generates the list of external declarations of each procedure
or function.
*/
Static Void generate_externals()
{
block_table *scan;
scan = blockptr;
while (scan != NULL) {
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(op_file, "extern ");
if (scan->b_type == functok) { /*externals*/
writok(&op_file, scan->return_);
putc(' ', op_file);
}
gen_header(&op_file, scan, true, true);
fprintf(op_file, " */\n");
} else { /*externals*/
gen_header(&op_file, scan, true, true);
if (omode == m6809)
fprintf(op_file, "EXTERNAL;\n");
else
fprintf(op_file, "EXTERN;\n");
}
putc('\n', op_file);
scan = scan->next;
} /*while*/
}
/*___________________________________________________________________________
Generate: A type declaration in C
This recursive procedure generates a definition of a type, given
a name and a type descriptor. It is impossible to generate a type
itself, as the name is buried within it in C. This is one of the
more trying aspects of C. For example
One must be careful of the precedence of operators such as [] and *.
char * mytype[80]
for mytype is ARRAY[0..79] OF ACCESS RPC_CHAR
On entry,
Cursor is assumed to be at left margin.
On exit,
Trailing semicolon and newline NOT done.
*/
Static Void gen_type_decl_C(where, expr, pt, level)
FILE **where;
expression expr;
defined_type *pt;
long level;
{
/* output file */
/* for the varaiable */
/* type structure */
/* indentation */
named_type *scan;
expression exp2;
/*gen_type_decl_c*/
switch (pt->typ_basic_type) { /*with, case*/
case chartok:
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok: /* First token, simple type, courier type */
fprintf(*where, "%*c", (int)LeftIn(level), ' ');
write_name(where,
&simple_descriptor[(long)pt->typ_basic_type - (long)chartok]->
typ_name->nty_name);
putc(' ', *where);
write_exp(where, &expr); /* Example: rpc_char x */
break;
/*simple type*/
case substring:
case stringtok: /*stringtok*/
/* Example: rpc_char x[81] */
fprintf(*where, "%*c", (int)LeftIn(level), ' ');
fprintf(*where, "rpc_char ");
write_exp(where, &expr);
fprintf(*where, "[%ld]", pt->UU.U12.typ_high + 1);
break;
case arraytok: /*arraytok*/
/* example int x[100] */
exp2 = expr;
append_1(&exp2, '[');
append_decimal(&exp2, pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1);
append_1(&exp2, ']');
gen_type_decl_C(where, exp2, pt->typ_subtype, level);
break;
case sequence:
exp2 = expr;
append_1(&exp2, '[');
append_decimal(&exp2, pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1);
/* 90613 */
append_1(&exp2, ']');
gen_type_decl_C(where, exp2, pt->typ_subtype, level);
break;
/*sequence*/
case accesstok:
exp2 = expr;
prepend_1(&exp2, '(');
prepend_1(&exp2, '*');
append_1(&exp2, ')'); /* Example: int (*x) */
gen_type_decl_C(where, exp2, pt->typ_subtype, level);
break;
case recordtok:
fprintf(*where, "%*cstruct {\n", (int)LeftIn(level), ' ');
scan = pt->UU.typ_fields;
while (scan != NULL) { /*while*/
exp2.len = 0;
append_name(&exp2, scan->nty_name);
gen_type_decl_C(where, exp2, scan->nty_type, level + 1);
fprintf(*where, ";\n");
scan = scan->nty_next;
}
fprintf(*where, "%*c} ", (int)LeftIn(level), ' ');
write_exp(where, &expr);
break;
}
}
/*___________________________________________________________________________
Generate: A type declaration in Pascal
This recursive procedure generates an expression for a type, given
a type descriptor.
Example:
ARRAY OF RECORD H: INTEGER; C: CHAR END
If a subtype has a name, that name will be used instead of elaborating
the subtype itself - For example, in Pascal pointers must be declared in
terms of the base type name, not a type expression.
On entry,
We assume any indentation required has been done for the 1st line.
On exit,
The semicolon and Newline on the end are not done.
*/
Static Void gen_type_pas(where, pt, level)
FILE **where;
defined_type *pt;
long level;
{
/* output file */
/* type structure */
/* indentation */
named_type *scan;
expression exp2;
/*gen_type_pas*/
if (level > 1 && pt->typ_name != NULL) {
write_name(where, &pt->typ_name->nty_name);
return;
}
switch (pt->typ_basic_type) { /*with, case*/
case chartok:
case bytetok:
case shortok:
case integertok:
case real32tok:
case real48tok:
case real64tok:
case real128tok:
case longtok: /* First token, simple type, courier type */
/* Example: rpc_char */
write_name(where,
&simple_descriptor[(long)pt->typ_basic_type - (long)chartok]->
typ_name->nty_name);
break;
/*simple type*/
case substring:
case stringtok: /*stringtok*/
/* Example: rpc_char x[81] */
if (omode == vaxvms && pt->typ_basic_type == stringtok) {
fprintf(*where, "RECORD strlen: rpc_short;\n");
fprintf(*where, "%*cDType, Cont: rpc_byte;\n",
(int)(LeftIn(level) + 8), ' ');
fprintf(*where, "%*cStrAdr: ^t_", (int)(LeftIn(level) + 8), ' ');
write_name(where, &pt->typ_name->nty_name);
fprintf(*where, "\n%*cEND", (int)(LeftIn(level) + 4), ' ');
} else if (omode == vaxpas && pt->typ_basic_type == stringtok)
fprintf(*where, "VARYING[%ld] OF CHAR", pt->UU.U12.typ_high);
else if (((1L << ((long)omode)) & ((1L << ((long)m6809)) |
(1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0 &&
pt->typ_basic_type == stringtok)
/* p2c: rpcc.p, line 7007: Note:
* Line breaker spent 0.7+0.81 seconds, 761 tries on line 8446 [251] */
fprintf(*where, "STRING[%ld]", pt->UU.U12.typ_high);
else
fprintf(*where, "PACKED ARRAY [1..%ld] OF CHAR", pt->UU.U12.typ_high);
break;
case arraytok: /*arraytok*/
/* example int x[100] */
fprintf(*where, "ARRAY [%ld..%ld] OF ",
pt->UU.U12.typ_low, pt->UU.U12.typ_high);
gen_type_pas(where, pt->typ_subtype, level + 1);
break;
case sequence:
fprintf(*where, "ARRAY [1..%ld] OF ", pt->UU.U12.typ_high);
gen_type_pas(where, pt->typ_subtype, level + 1);
break;
/*sequence*/
case accesstok:
putc('^', *where);
gen_type_pas(where, pt->typ_subtype, level + 1);
break;
case recordtok:
fprintf(*where, "RECORD\n");
scan = pt->UU.typ_fields;
while (scan != NULL) { /*while*/
exp2.len = 0;
fprintf(*where, "%*c", (int)(LeftIn(level) + 4), ' ');
write_name(where, &scan->nty_name);
fprintf(*where, ": ");
gen_type_pas(where, scan->nty_type, level + 1);
fprintf(*where, ";\n");
scan = scan->nty_next;
}
fprintf(*where, "%*cEND {RECORD}", (int)LeftIn(level), ' ');
break;
}
/*if*/
}
/*___________________________________________________________________________
Generate type definitions for whole package
Example:
typedef rpc_char xxxxx;
typedef rpc_integer my_array[80];
or:
xxxxx = rpc_char;
my_array = ARRAY[1..80] OF rpc_integer;
*/
Static Void generate_types(where)
FILE **where;
{ /*generate types*/
named_type *scan;
expression expr;
named_type *WITH;
scan = typeptr;
while (scan != NULL) { /*end_while*/
WITH = scan;
/* Just specially for the VAX/VMS, define a basic array type for each
length of string by descriptor:
*/
if (omode == vaxvms) {
if (WITH->nty_type->typ_basic_type == stringtok)
{ /* Define char array: */
fprintf(*where, "t_"); /* jammy! */
write_name(where, &WITH->nty_name);
fprintf(*where, " = ");
fprintf(*where, "PACKED ARRAY [1..%ld] OF CHAR;\n",
WITH->nty_type->UU.U12.typ_high);
} /*if*/
}
/* Now make the main type definition:
*/
expr.len = 0;
append_name(&expr, WITH->nty_name); /* expr is name of variable */
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(*where, "typedef ");
gen_type_decl_C(where, expr, WITH->nty_type, 1L);
} else { /*if*/
write_name(where, &WITH->nty_name);
fprintf(*where, " = ");
gen_type_pas(where, WITH->nty_type, 1L);
}
fprintf(*where, ";\n");
scan = WITH->nty_next;
}
putc('\n', *where);
}
/*_____________________________________________________________________________
Generate External Definition File
=================================
PILS and FORTRAN do not get declaraction files generated, as they
don't do enough type checking to merit it.
*/
Static Void ext_generator(ext_mode, ext_name)
output_mode ext_mode;
astring ext_name;
{
if (((1L << ((long)omode)) & ((1L << ((long)pils)) | (1L << ((long)vaxfor)))) != 0)
return;
if (!file_open(&op_file, &ext_name, rewriting)) {
error(cant_opn_ext);
return;
}
client = false;
omode = ext_mode;
putc('\n', op_file);
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "/* ");
else
fprintf(op_file, "{* ");
fprintf(op_file, "Stub Version Number: ");
if (version_num == 0)
fprintf(op_file, "zero (no check)");
else
fprintf(op_file, "%ld", version_num);
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " */\n");
else
fprintf(op_file, " *}\n");
putc('\n', op_file);
if (runoptions[(long)types - (long)ccerncross].value && typeptr != NULL) {
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(op_file, "TYPE\n");
generate_types(&op_file);
}
generate_externals();
if (!file_close(&op_file))
error(cant_cls_ext);
} /*EXT_GENERATOR*/
/* Local variables for gen_module: */
struct LOC_gen_module {
FILE **where;
} ;
Local Void do_include(which, LINK)
Char *which;
struct LOC_gen_module *LINK;
{
long i;
fprintf(*LINK->where, "*INCLUDE rpc");
for (i = 0; i <= 9; i++) {
if (which[i] != ' ')
putc(which[i], *LINK->where);
}
putc('\n', *LINK->where);
}
/*_____________________________________________________________________________
Generate Module Declaration Code
================================
Generates the heading, CONST, TYPE and VAR sections of a stub module,
and the standard include files.
*/
Static Void gen_module(where_)
FILE **where_;
{
/* Invoke Include file
| -------------------
|
| On VMS, the file is referred to by a logical name (no . in it, and a $
| to avoid conflict with real files).
*/
struct LOC_gen_module V;
/* Main block for Gen_module
-------------------------
Generates: The module header
The constant and type definitions
*/
/** Generate header according to xxx_mode **/
V.where = where_;
putc('\n', *V.where);
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(*V.where, "#include <rpcrts.h>\n\n");
else {
if (((1L << ((long)omode)) & ((1L << ((long)monolith)) |
(1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) == 0) {
/* p2c: rpcc.p, line 7325: Note:
* Line breaker spent 1.4+0.51 seconds, 318 tries on line 8650 [251] */
fprintf(*V.where, "MODULE ");
if (client)
fprintf(*V.where, "CLI");
else
fprintf(*V.where, "SER");
write_name(V.where, &unitname);
fprintf(*V.where, ";\n");
}
if (((1L << ((long)omode)) &
((1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0) {
fprintf(*V.where, "UNIT ");
if (client)
fprintf(*V.where, "CLI");
else
fprintf(*V.where, "SER");
write_name(V.where, &unitname);
/* For MacTurbo, a unit number, in parenthesis, is required between
the unit name and the semicolon terminating the unit header.
This number (a positive 16-bit integer constant) should be
different from any other unit number that the user program might
use. The current allocation of unit numbers (MacTurbo version)
is:
Module Unit Number
RPCMacPas 1
RPCStub 2
TSTurbo 3
RPCRTS 4
That's why we use the unit number 5 for stub modules. If more
stubs have to be combined in a single program, the user will
need to modify stub unit numbers in order to ensure their
uniqueness.
*/
if (omode == macturbo)
fprintf(*V.where, "(5)");
fprintf(*V.where, ";\n");
fprintf(*V.where, "INTERFACE\n");
if (omode == pcturbo) {
fprintf(*V.where, "USES rpcpcpas,\n");
fprintf(*V.where, " rpcstub,\n");
fprintf(*V.where, " tsturbo,\n");
if (external_marshalling)
fprintf(*V.where, " extmarsh,\n");
fprintf(*V.where, " rpcrts");
} else {
fprintf(*V.where, "{$U RPCMacPas}\n");
fprintf(*V.where, "{$U RPCStub}\n");
fprintf(*V.where, "{$U TSTurbo}\n");
if (external_marshalling)
fprintf(*V.where, "{$U extmarsh}\n");
fprintf(*V.where, "{$U RPCRTS}\n");
if (!client) {
fprintf(*V.where,
"{--> It is assumed, by default, that the name of the unit library file <--}\n");
fprintf(*V.where,
"{--> containing the server routines is the same as the package name. <--}\n");
fprintf(*V.where,
"{--> If the assumption is wrong, just replace the following line. <--}\n");
fprintf(*V.where, "{$U ");
write_name(V.where, &unitname);
fprintf(*V.where, "}\n");
}
fprintf(*V.where, "\nUSES MemTypes,\n");
fprintf(*V.where, " QuickDraw,\n");
fprintf(*V.where, " OSIntf,\n");
fprintf(*V.where, " ToolIntf,\n");
fprintf(*V.where, " RPCMacPas,\n");
fprintf(*V.where, " RPCStub,\n");
fprintf(*V.where, " TSTurbo,\n");
if (external_marshalling)
fprintf(*V.where, " extmarsh,\n");
fprintf(*V.where, " RPCRTS");
}
if (!client) {
fprintf(*V.where, ",\n");
fprintf(*V.where,
"{--> It is assumed, by default, that the name of the unit containing <--}\n");
fprintf(*V.where,
"{--> the server routines is the same as the package name. If the <--}\n");
fprintf(*V.where,
"{--> assumption is wrong, just replace the following line. <--}\n");
fprintf(*V.where, " ");
write_name(V.where, &unitname);
}
fprintf(*V.where, ";\n\n");
if (!client && typeptr != NULL) {
fprintf(*V.where,
"{--> Being this a server stub, the TYPE declarations should not be <--}\n");
fprintf(*V.where,
"{--> included here (they belong to the unit containing the server <--}\n");
fprintf(*V.where,
"{--> routines). However you will find them below (commented out), in <--}\n");
fprintf(*V.where,
"{--> case you need them for reference. <--}\n");
fprintf(*V.where, "{\n");
}
if (typeptr != NULL)
fprintf(*V.where, "TYPE\n");
} else { /*if*/
fprintf(*V.where, "\nCONST\n");
do_include("const.h ", &V); /* Include rpc constants file */
/** Generate types **/
fprintf(*V.where, "\nTYPE\n");
do_include("types.h ", &V); /* Include rpc types file */
}
}
generate_types(V.where); /* generate local types */
/* For MacTurbo and PCTurbo server stubs stop commenting. */
if (!client &&
((1L << ((long)omode)) &
((1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0 &&
typeptr != NULL)
/* p2c: rpcc.p, line 7325: Note:
* Line breaker spent 0.8+0.98 seconds, 737 tries on line 8778 [251] */
fprintf(*V.where, "}\n");
/* Generate global variables (handle for client, program index for server)
*/
if (client) {
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(*V.where, "rpc_handle h_"); /* 891206 */
write_name(V.where, &unitname);
fprintf(*V.where, ";\n");
} else {
if (omode == cerncross)
fprintf(*V.where, "EXPORT\n");
else
fprintf(*V.where, "VAR\n");
fprintf(*V.where, " h_");
write_name(V.where, &unitname);
if (((1L << ((long)omode)) &
((1L << ((long)vaxvms)) | (1L << ((long)vaxpas)))) != 0)
fprintf(*V.where, ": [global] integer;\n");
else if (omode == m6809)
fprintf(*V.where, ": integer external;\n"); /*70604*/
else if (((1L << ((long)omode)) &
((1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0)
fprintf(*V.where, ": client_pointer;\n"); /*80429*/
else
fprintf(*V.where, ": integer;\n");
}
} else { /*server*/
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(*V.where, "program_index p_");
write_name(V.where, &unitname);
fprintf(*V.where, ";\n");
} else /*if pascal*/
{ /*pascal*/
if (omode == cerncross)
fprintf(*V.where, "EXPORT\n");
else
fprintf(*V.where, "VAR\n");
fprintf(*V.where, " p_");
write_name(V.where, &unitname);
if (((1L << ((long)omode)) &
((1L << ((long)vaxvms)) | (1L << ((long)vaxpas)))) != 0) {
fprintf(*V.where, ": [global] integer;\n");
/**** else if (omode = m6809)
then writeln(where, ': program_index external ;') ****/
} else if (((1L << ((long)omode)) &
((1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0)
fprintf(*V.where, ": program_pointer;\n");
else
fprintf(*V.where, ": program_index;\n");
}
}
putc('\n', *V.where);
if (((1L << ((long)omode)) &
(Cmode | (1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) == 0) {
do_include("proc.h ", &V); /* External definitions of RTS */
do_include("stub.h ", &V); /* Local stub procedures */
putc('\n', *V.where);
}
/* Declare external marshalling routines if needed:
*/
if (external_marshalling) {
if (((1L << ((long)omode)) & (Cmode | (1L << ((long)cerncross)) |
(1L << ((long)vaxvms)) | (1L << ((long)vaxpas)) |
(1L << ((long)unixbsd)) | (1L << ((long)m6809)))) != 0)
/* p2c: rpcc.p, line 7325: Note:
* Line breaker spent 2.8+3.94 seconds, 1195 tries on line 8848 [251] */
decl_ext_marshal();
}
/** if omode in [pcturbo, macturbo] then writeln(where, 'IMPLEMENTATION'); **/
if (!client && ((1L << ((long)omode)) &
((1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) == 0)
generate_externals();
/* For MacTurbo things are more complicated. */
/** Generate constants **/
} /*GEN_MODULE*/
/* Local variables for client_generator: */
struct LOC_client_generator {
long proc_number;
} ;
/*___________________________________________________
*/
Local Void gen_client_block_pas(ptr, LINK)
block_table *ptr;
struct LOC_client_generator *LINK;
{
/****
* On each block, the client allocates 'RPC_integer' variables to pack or
* unpack parameters.
*****/
long a;
expression return_value; /* Expression for return value */
long FORLIM;
/** generate and print procedure header **/
if (((1L << ((long)omode)) &
((1L << ((long)vaxvms)) | (1L << ((long)vaxpas)))) != 0)
fprintf(op_file, "[GLOBAL]\n");
/* 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, omode != macturbo);
if (omode == m6809)
fprintf(op_file, " ENTRY;\n");
/** print local vars and buffer allocation **/
fprintf(op_file, "VAR rpc_p_buf: rpc_message_pointer;\n");
FORLIM = ptr->blk_nesting + 96;
for (a = 97; a <= FORLIM; a++)
fprintf(op_file, " rpc_%c : rpc_integer;\n", (Char)a);
if (ptr->b_type == functok) {
fprintf(op_file, " rpc_ret : ");
writok(&op_file, ptr->return_);
fprintf(op_file, ";\n");
}
fprintf(op_file, "BEGIN\n");
fprintf(op_file, " rpc_begin(rpc_p_buf, h_");
write_name(&op_file, &unitname);
fprintf(op_file, ", {vers=}%ld, {proc=}%ld);\n",
version_num, LINK->proc_number);
fprintf(op_file, " WITH rpc_p_buf^ DO BEGIN\n");
/** generate packing statements for IN & INOUT params **/
if (ptr->list != NULL)
gen_pack(&op_file, ptr->list, intok, true);
fprintf(op_file, " END {WITH};\n"); /* 71006 */
/** generate rpc_call and bookeeping **/
fprintf(op_file, " ");
if (ptr->blk_status_param != NULL) { /*if*/
write_name(&op_file, &ptr->blk_status_param->name);
fprintf(op_file, " := ");
}
if (ptr->blk_cast)
fprintf(op_file, "rpc_cast");
else
fprintf(op_file, "rpc_call");
if (ptr->blk_status_param != NULL)
fprintf(op_file, "_status");
fprintf(op_file, "(h_");
write_name(&op_file, &unitname);
fprintf(op_file, ", rpc_p_buf");
if (!ptr->blk_cast)
fprintf(op_file, ",%ld", ptr->blk_timeout);
fprintf(op_file, ");\n");
if (ptr->blk_status_param != NULL) { /*if*/
fprintf(op_file, " IF odd(");
write_name(&op_file, &ptr->blk_status_param->name);
fprintf(op_file, ") THEN ");
}
fprintf(op_file, " WITH rpc_p_buf^ DO BEGIN\n"); /* 71006 */
size_so_far = 0; /* No unmarshalling code generated yet */
if (ptr->blk_max_out > 0) { /*if*/
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " rpc_p_buf->m_index =");
else
fprintf(op_file, " m_index :=");
fprintf(op_file, " RETURN_HEADER_LENGTH;\n");
}
/** if function: unpack return value **/
if (ptr->b_type == functok) {
fprintf(op_file, " ");
dopack_simple(&op_file, ptr->return_, false);
fprintf(op_file, "rpc_ret);\n");
}
/** generate UNpacking statements for OUT and INOUT params **/
if (ptr->list != NULL)
gen_pack(&op_file, ptr->list, outok, false);
/** clear up everything and exit **/
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(op_file, " c_dispose(rpc_p_buf);\n");
if (ptr->b_type == functok)
fprintf(op_file, " return(rpc_ret);\n");
fprintf(op_file, " }\n");
} else {
if (ptr->b_type == functok) {
fprintf(op_file, " ");
write_name(&op_file, &ptr->name);
fprintf(op_file, " := rpc_ret;\n");
}
fprintf(op_file, " END {WITH};\n");
fprintf(op_file, " rpc_dispose(rpc_p_buf);\n");
fprintf(op_file, "END;\n");
}
putc('\n', op_file);
} /*gen_client_block_pas*/
/*___________________________________________________
*/
Local Void gen_client_block_c(ptr, LINK)
block_table *ptr;
struct LOC_client_generator *LINK;
{
/****
* On each block, the client allocates 'RPC_integer' variables to pack or
* unpack parameters.
*****/
long a;
expression return_value; /* Expression for return value */
long FORLIM;
/** generate and print procedure header **/
size_so_far = 0; /* No marshalling code generated yet */
gen_header(&op_file, ptr, false, true);
/** print local vars and buffer allocation **/
fprintf(op_file, "\n{ rpc_message *rpc_p_buf;\n");
FORLIM = ptr->blk_nesting + 96;
for (a = 97; a <= FORLIM; a++)
fprintf(op_file, " register rpc_integer rpc_%c;\n", (Char)a);
if (ptr->b_type == functok) {
fprintf(op_file, " ");
writok(&op_file, ptr->return_);
fprintf(op_file, " rpc_ret;\n");
}
fprintf(op_file, "\n ");
fprintf(op_file, "c_begin(rpc_p_buf, h_");
write_name(&op_file, &unitname);
fprintf(op_file, ", /*vers=*/%ld, /*proc=*/%ld);\n",
version_num, LINK->proc_number);
/** generate packing statements for IN & INOUT params **/
if (ptr->list != NULL)
gen_pack(&op_file, ptr->list, intok, true);
/** generate rpc_call and bookeeping **/
fprintf(op_file, " ");
if (ptr->blk_status_param != NULL) { /*if*/
putc('*', op_file);
write_name(&op_file, &ptr->blk_status_param->name);
fprintf(op_file, " = ");
}
fprintf(op_file, "c_call");
if (ptr->blk_status_param != NULL)
fprintf(op_file, "_status");
fprintf(op_file, "(h_");
write_name(&op_file, &unitname);
fprintf(op_file, ", rpc_p_buf, %ld);\n", ptr->blk_timeout);
if (ptr->blk_status_param != NULL) { /*if*/
fprintf(op_file, " if (*");
write_name(&op_file, &ptr->blk_status_param->name);
fprintf(op_file, " & 1) { /* If good call */ \n");
}
size_so_far = 0; /* No unmarshalling code generated yet */
if (ptr->blk_max_out > 0)
fprintf(op_file, " rpc_p_buf->m_index = RETURN_HEADER_LENGTH;\n");
/** if function: unpack return value **/
if (ptr->b_type == functok) {
fprintf(op_file, " ");
dopack_simple(&op_file, ptr->return_, false);
fprintf(op_file, "rpc_ret);\n");
}
/** generate UNpacking statements for OUT and INOUT params **/
if (ptr->list != NULL)
gen_pack(&op_file, ptr->list, outok, false);
if (ptr->blk_status_param != NULL)
fprintf(op_file, " } /* end if good call */\n");
/** clear up everything and exit **/
fprintf(op_file, " c_dispose(rpc_p_buf);\n");
if (ptr->b_type == functok)
fprintf(op_file, " return(rpc_ret);\n");
fprintf(op_file, " }\n\n");
} /*gen_client_block_c*/
/*___________________________________________________
*/
Local Void gen_open__(LINK)
struct LOC_client_generator *LINK;
{
if (((1L << ((long)omode)) &
((1L << ((long)vaxvms)) | (1L << ((long)vaxpas)))) != 0) {
if (runoptions[(long)noautoinit - (long)ccerncross].value)
fprintf(op_file, "[GLOBAL]\n");
else
fprintf(op_file, "[GLOBAL, INITIALIZE]\n");
}
writok(&op_file, proctok);
fprintf(op_file, "open_");
write_name(&op_file, &unitname);
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "()\n");
else
fprintf(op_file, ";\n");
if (omode == m6809)
fprintf(op_file, " ENTRY;\n");
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "{ rpc_status status;\n");
else {
fprintf(op_file, "VAR\n");
fprintf(op_file, " status : rpc_status;\n");
fprintf(op_file, " service : rpc_name;\n");
fprintf(op_file, "BEGIN\n");
fprintf(op_file, " service := ");
write_name_padded(&op_file, unitname, '\'');
fprintf(op_file, ";\n");
}
if (((1L << ((long)omode)) & Cmode) != 0)
putc('\n', op_file);
fprintf(op_file, " ");
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(op_file, "rp");
fprintf(op_file, "c_open(status, h_");
write_name(&op_file, &unitname);
fprintf(op_file, ", ");
if (((1L << ((long)omode)) & Cmode) != 0)
write_name_padded(&op_file, unitname, '"');
else
fprintf(op_file, "service");
fprintf(op_file, ");\n");
fprintf(op_file, " ");
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(op_file, "rp");
fprintf(op_file, "c_report_error(status);\n");
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " }\n");
else
fprintf(op_file, "END;\n");
} /*GEN_OPEN*/
/*______________________________________________
Generate procedure to close stub: close_xxx()
In PCturbo, this is a valid exit procedure, which replaces the exit
procedure pointer when it is done.
*/
Local Void gen_close_(LINK)
struct LOC_client_generator *LINK;
{
if (((1L << ((long)omode)) &
((1L << ((long)vaxvms)) | (1L << ((long)vaxpas)))) != 0)
fprintf(op_file, "[GLOBAL]\n");
writok(&op_file, proctok);
fprintf(op_file, "close_");
write_name(&op_file, &unitname);
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "()\n");
else
fprintf(op_file, ";\n");
if (omode == m6809)
fprintf(op_file, " ENTRY;\n");
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "{ rpc_status status;\n\n");
else {
fprintf(op_file, "VAR\n");
fprintf(op_file, " status : rpc_status;\n");
fprintf(op_file, "BEGIN\n");
}
fprintf(op_file, " ");
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(op_file, "rp");
fprintf(op_file, "c_close(status, h_");
write_name(&op_file, &unitname);
fprintf(op_file, ");\n");
fprintf(op_file, " ");
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(op_file, "rp");
fprintf(op_file, "c_report_error(status);\n");
if (omode == pcturbo) {
fprintf(op_file, " ExitProc := e_");
write_name(&op_file, &unitname);
fprintf(op_file, ";\n");
}
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " }\n");
else
fprintf(op_file, "END;\n");
} /*gen_close*/
/*******************************************************************************
Client code generator
=====================
Generates one procedure or function for the client.
*/
Static Void client_generator(client_mode, cli_name)
output_mode client_mode;
astring cli_name;
{
struct LOC_client_generator V;
block_table *scan;
/*______________________________________________________
*/
if (!file_open(&op_file, &cli_name, rewriting)) {
error(cant_opn_client);
return;
}
omode = client_mode;
client = true;
fragmentation_used = false;
if (omode == pils)
client_generator_pils();
else if (omode == vaxfor)
client_gen_for();
else {
/** Generate module name and type, var, procedure inclusion **/
if (omode != monolith)
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) {
fprintf(op_file, " e_"); /* Add a variable for close_x */
write_name(&op_file, &unitname);
fprintf(op_file, ": pointer;\n");
}
if (((1L << ((long)omode)) &
((1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0) {
/* For MacTurbo and PCTurbo the global procedure headings
must appearin the interface part.
For MacTurbo we must generate the procedure heading
formal parameter part ONLY in the INTERFACE section.
*/
V.proc_number = 1;
scan = blockptr;
while (scan != NULL) { /*while*/
gen_header(&op_file, scan, false, true);
V.proc_number++;
scan = scan->next;
}
fprintf(op_file, "PROCEDURE open_");
write_name(&op_file, &unitname);
fprintf(op_file, ";\n");
fprintf(op_file, "PROCEDURE close_");
write_name(&op_file, &unitname);
fprintf(op_file, ";\n\n");
fprintf(op_file, "IMPLEMENTATION\n\n");
}
/** Generate procedures **/
V.proc_number = 1;
scan = blockptr;
while (scan != NULL) {
if (((1L << ((long)omode)) & Cmode) != 0)
gen_client_block_c(scan, &V);
else
gen_client_block_pas(scan, &V);
V.proc_number++;
scan = scan->next;
}
gen_open__(&V);
gen_close_(&V); /* Added for all versions now 8-May-1989 */
/* Specials for PCTurbo and MacTurbo : Autoinit.
*/
/* Exit handler only in PCTurbo version. */
if (((1L << ((long)omode)) &
((1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0)
{ /*if*/
if (!runoptions[(long)noautoinit - (long)ccerncross].value ||
omode == pcturbo)
fprintf(op_file, "BEGIN\n");
if (omode == pcturbo) {
fprintf(op_file, " e_");
write_name(&op_file, &unitname);
fprintf(op_file, " := ExitProc;\n");
fprintf(op_file, " ExitProc := @close_");
write_name(&op_file, &unitname);
fprintf(op_file, ";\n");
}
if (!runoptions[(long)noautoinit - (long)ccerncross].value) {
fprintf(op_file, " open_");
write_name(&op_file, &unitname);
fprintf(op_file, ";\n");
}
fprintf(op_file, "END.\n");
}
/** Generate end of module **/
if (((1L << ((long)omode)) &
((1L << ((long)vaxvms)) | (1L << ((long)vaxpas)))) != 0)
fprintf(op_file, "END .\n");
else if (omode == m6809)
fprintf(op_file, "MODEND .\n");
else if (omode == cerncross)
fprintf(op_file, ".\n");
}
if (fragmentation_used)
printf("Buffer fragmentation may be used for large parameters.\n");
if (!file_close(&op_file))
error(cant_cls_client);
/*if not pils or FORTRAN*/
} /*CLIENT_GENERATOR*/
/* Local variables for server_generator: */
struct LOC_server_generator {
block_table *scan;
} ;
/* Local variables for gen_server_block: */
struct LOC_gen_server_block {
struct LOC_server_generator *LINK;
id_list *scanlist;
} ;
Local Void write_Camp(LINK)
struct LOC_gen_server_block *LINK;
{
fprintf(op_file, ", ");
if (((1L << ((long)omode)) & Cmode) != 0 &&
!(runoptions[(long)byvalue - (long)ccerncross].value &&
LINK->scanlist->attr == intok))
putc('&', op_file);
}
/* Generate server stub for one Procedure/function
-----------------------------------------------
*/
Local Void gen_server_block(ptr, LINK)
block_table *ptr;
struct LOC_server_generator *LINK;
{
/****
* On each block, the server allocates 'RPC_integer' variables to pack or
* unpack parameters, accoring to the maximum number (blk_nesting) needed
* at any one time.
*****/
struct LOC_gen_server_block V;
long a, par_count; /* how far we are getting across line */
long FORLIM;
V.LINK = LINK;
size_so_far = 0; /* No unmarshalling code generated yet */
/** generate and print procedure header **/
gen_header(&op_file, ptr, false, true);
FORLIM = ptr->blk_nesting + 96;
/** print local vars and buffer allocation **/
for (a = 97; a <= FORLIM; a++) {
fprintf(op_file, " ");
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "register rpc_integer ");
fprintf(op_file, "rpc_%c", (Char)a);
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(op_file, " : rpc_integer");
fprintf(op_file, ";\n");
}
if (((1L << ((long)omode)) & Cmode) != 0)
putc('\n', op_file);
else {
fprintf(op_file, "BEGIN\n");
fprintf(op_file, " WITH rpc_p_buf^ DO BEGIN\n");
}
/** generate UNpacking statements for IN and INOUT params **/
if (ptr->list != NULL)
gen_pack(&op_file, ptr->list, intok, false);
/* Generate call and bookeeping:
*/
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " c_turn(rpc_p_buf);\n");
else { /*pascal*/
fprintf(op_file, " rpc_p_buf^.which := RETURN_MESSAGE;\n");
fprintf(op_file, " rpc_p_buf^.m_index := RETURN_HEADER_LENGTH;\n");
} /*if pascal*/
size_so_far = 0; /* No marshalling code generated yet */
if (ptr->b_type == proctok && ptr->in_only) {
if (runoptions[(long)concurrent - (long)ccerncross].value ||
ptr->blk_concurrent) {
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " c");
else
fprintf(op_file, " rpc");
fprintf(op_file, "_early_return(rpc_p_buf);\n");
} else if (ptr->blk_cast) {
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " rpc_p_buf->m_status=1;\n");
else
fprintf(op_file, " m_status:=1;\n");
}
}
fprintf(op_file, " ");
/* If function: generate return variable **/
if (ptr->b_type == functok)
dopack_simple(&op_file, ptr->return_, true);
/* Generate list of variables:
*/
write_name(&op_file, &ptr->name);
if (ptr->list != NULL) {
putc('(', op_file);
V.scanlist = ptr->list;
par_count = 1;
do {
/* Generate address of simple types and records in C if necessary:
*/
if (((1L << ((long)omode)) & Cmode) != 0 &&
((1L << ((long)V.scanlist->id_type->typ_basic_type)) &
(((1L << ((long)longtok + 1)) - (1L << ((long)chartok))) |
(1L << ((long)recordtok)))) != 0 &&
!(runoptions[(long)byvalue - (long)ccerncross].value &&
V.scanlist->attr == intok))
/* p2c: rpcc.p, line 8231: Note:
* Line breaker spent 2.7+0.64 seconds, 4426 tries on line 9458 [251] */
putc('&', op_file);
/* If var is SEQUENCE or SUBSTRING or STRING put all names
*/
if (V.scanlist->id_type->typ_basic_type == sequence) {
fprintf(op_file, "a_");
write_name(&op_file, &V.scanlist->name);
par_count++;
write_Camp(&V);
fprintf(op_file, "l_");
} else if (V.scanlist->id_type->typ_basic_type == substring) {
fprintf(op_file, "a_");
write_name(&op_file, &V.scanlist->name);
write_Camp(&V);
fprintf(op_file, "s_");
write_name(&op_file, &V.scanlist->name);
par_count += 2;
write_Camp(&V);
fprintf(op_file, "l_");
} else if (V.scanlist->id_type->typ_basic_type == stringtok &&
((1L << ((long)omode)) & (Cmode | (1L << ((long)vaxvms)) |
(1L << ((long)vaxpas)) | (1L << ((long)m6809)) |
(1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) == 0) {
/* p2c: rpcc.p, line 8231: Note:
* Line breaker spent 1.6+0.48 seconds, 3198 tries on line 9483 [251] */
fprintf(op_file, "a_");
write_name(&op_file, &V.scanlist->name);
par_count++;
fprintf(op_file, ", l_");
}
/* Write the main parameter name:
*/
write_name(&op_file, &V.scanlist->name);
par_count++;
V.scanlist = V.scanlist->next;
if (V.scanlist != NULL) { /*if*/
fprintf(op_file, ", ");
if (par_count > 3) { /* Line wrap around */
fprintf(op_file, "\n ");
par_count = 0;
}
}
} while (V.scanlist != NULL);
putc(')', op_file);
} else if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "()");
/** if function generates return variable **/
if (ptr->b_type == functok)
putc(')', op_file);
fprintf(op_file, ";\n");
/** generate packing statements for OUT and INOUT params**/
if (ptr->list != NULL)
gen_pack(&op_file, ptr->list, outok, true);
/** writeln(op_file, ' rpc_early_return(rpc_p_buf, m_index);'); oct 86 **/
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " }\n");
else {
fprintf(op_file, " END {with};\n");
fprintf(op_file, "END;\n");
}
putc('\n', op_file);
} /*gen_server_block*/
/* Generate Main Server Procedure
------------------------------
*/
Local Void gen_jump_proc(LINK)
struct LOC_server_generator *LINK;
{
long proc_num;
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(op_file, "static rpc_message *rpc_p_buf;\n\n");
LINK->scan = blockptr;
proc_num = 0;
while (LINK->scan != NULL) {
gen_server_block(LINK->scan, LINK);
LINK->scan = LINK->scan->next;
proc_num++;
}
}
if (((1L << ((long)omode)) &
((1L << ((long)vaxvms)) | (1L << ((long)vaxpas)))) != 0)
fprintf(op_file, "[GLOBAL]\n");
writok(&op_file, proctok);
fprintf(op_file, "r_");
write_name(&op_file, &unitname);
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "(rpc_a) rpc_message **rpc_a;\n"); /* 71217 */
else
fprintf(op_file, "(VAR rpc_p_buf : rpc_message_pointer);\n");
if (omode == m6809)
fprintf(op_file, " ENTRY;\n");
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "{ rpc_short request;\n");
else {
fprintf(op_file, "VAR\n");
fprintf(op_file, " request : rpc_short;\n");
}
/** writeln(op_file, ' status: rpc_status;'); **/
/* All the procedures to service each procedure/function are
now declared as local to the jump procedure. In this way they
can use the parameter rpc_p_buf (TBL Oct 86).
EXCEPT in Cmode: here the service functions are declared static
and beforehand; rpc_p_buf is a static global that is set on entry
to this procedure (Nici Aug 87).
*/
if (((1L << ((long)omode)) & Cmode) == 0) {
LINK->scan = blockptr;
proc_num = 0;
while (LINK->scan != NULL) {
gen_server_block(LINK->scan, LINK);
LINK->scan = LINK->scan->next;
proc_num++;
}
fprintf(op_file, "BEGIN\n");
fprintf(op_file, " WITH rpc_p_buf^ DO BEGIN\n");
fprintf(op_file, " m_index :");
} else {
fprintf(op_file, "\n rpc_p_buf = *rpc_a;\n");
/* 71217 */
fprintf(op_file, " rpc_p_buf->m_index ");
}
fprintf(op_file, "= CALL_HEADER_LENGTH - ");
if (version_num == 0)
fprintf(op_file, "2;\n");
else {
fprintf(op_file, "4;\n");
fprintf(op_file, " upk_short(rpc_p_buf, request);\n");
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(op_file, " if (request != 0 && request != %ld)\n",
version_num);
fprintf(op_file,
" rpc_p_buf->m_status = RPC_S_UNSUPPORTED_VERSION;\n");
fprintf(op_file, " else {\n");
} else {
fprintf(op_file, " IF (request<>0) AND (request<>%ld)\n",
version_num);
fprintf(op_file, " THEN m_status := RPC_S_UNSUPPORTED_VERSION\n");
fprintf(op_file, " ELSE begin\n");
}
}
fprintf(op_file, " upk_short(rpc_p_buf, request);\n");
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(op_file, " switch (request)\n");
fprintf(op_file, " { ");
} else {
fprintf(op_file, " IF (request = 0) OR (request > %ld) THEN\n",
proc_num);
fprintf(op_file, " m_status := RPC_S_BAD_PROCEDURE_NUMBER\n");
fprintf(op_file, " ELSE CASE request OF\n");
fprintf(op_file, " ");
}
LINK->scan = blockptr;
proc_num = 1;
while (LINK->scan != NULL) {
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "case ");
fprintf(op_file, "%2ld : r_", proc_num);
write_name(&op_file, &LINK->scan->name);
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "()");
fprintf(op_file, ";\n");
proc_num++;
LINK->scan = LINK->scan->next;
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " break;\n");
fprintf(op_file, " ");
}
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(op_file,
"default : rpc_p_buf->m_status = RPC_S_BAD_PROCEDURE_NUMBER;\n");
fprintf(op_file, " }\n");
if (version_num != 0) /* switch */
fprintf(op_file, " }\n");
fprintf(op_file, " }\n"); /* if else */
} else {
fprintf(op_file, "END {case};\n");
if (version_num != 0)
fprintf(op_file, " END {if};\n");
fprintf(op_file, " END {with};\n");
fprintf(op_file, "END;\n");
}
putc('\n', op_file);
} /*GEN_JUMP_PROC*/
/* Generate Code to Attach stub to RPCRTS
--------------------------------------
*/
Local Void gen_attach_(LINK)
struct LOC_server_generator *LINK;
{
if (((1L << ((long)omode)) &
((1L << ((long)vaxvms)) | (1L << ((long)vaxpas)))) != 0) {
if (runoptions[(long)noautoinit - (long)ccerncross].value)
fprintf(op_file, "[GLOBAL]\n");
else
fprintf(op_file, "[GLOBAL, INITIALIZE]\n");
}
writok(&op_file, proctok);
fprintf(op_file, "attach_");
write_name(&op_file, &unitname);
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "()\n");
else
fprintf(op_file, ";\n");
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "{ rpc_status status;\n\n");
else {
fprintf(op_file, "VAR\n");
fprintf(op_file, " status : rpc_status;\n");
fprintf(op_file, " service : rpc_name;\n");
fprintf(op_file, "BEGIN\n");
fprintf(op_file, " service := ");
write_name_padded(&op_file, unitname, '\'');
fprintf(op_file, ";\n");
}
fprintf(op_file, " ");
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(op_file, "rp");
/* For PCTurbo and MacTurbo use the @ operator to pass the stub pointer. */
if (((1L << ((long)omode)) &
((1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0)
fprintf(op_file, "c_attach_stub(status, @r_");
else
fprintf(op_file, "c_attach_stub(status, r_");
write_name(&op_file, &unitname);
fprintf(op_file, ", ");
if (((1L << ((long)omode)) & Cmode) != 0) {
fprintf(op_file, "\n ");
write_name_padded(&op_file, unitname, '"');
} else
fprintf(op_file, "service");
fprintf(op_file, ", p_");
write_name(&op_file, &unitname);
fprintf(op_file, ");\n");
fprintf(op_file, " ");
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(op_file, "rp");
fprintf(op_file, "c_report_error(status);\n");
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " }\n");
else
fprintf(op_file, "END;\n");
} /*GEN_ATTACH*/
/* Generate Code to Detach stub from RPCRTS
----------------------------------------
*/
Local Void gen_detach_(LINK)
struct LOC_server_generator *LINK;
{
if (((1L << ((long)omode)) &
((1L << ((long)vaxvms)) | (1L << ((long)vaxpas)))) != 0)
fprintf(op_file, "[GLOBAL]\n");
writok(&op_file, proctok);
fprintf(op_file, "detach_");
write_name(&op_file, &unitname);
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "()\n");
else
fprintf(op_file, ";\n");
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, "{\n");
else
fprintf(op_file, "BEGIN\n");
fprintf(op_file, " ");
if (((1L << ((long)omode)) & Cmode) == 0)
fprintf(op_file, "rp");
fprintf(op_file, "c_detach_stub(p_");
write_name(&op_file, &unitname);
fprintf(op_file, ");\n");
if (((1L << ((long)omode)) & Cmode) != 0)
fprintf(op_file, " }\n");
else
fprintf(op_file, "END;\n");
} /*gen_detach*/
/******************************************************************************
S E R V E R C O D E G E N E R A T O R
*************************************************
The server stub is produced according to
*/
Static Void server_generator(server_mode, ser_name)
output_mode server_mode;
astring ser_name;
{
struct LOC_server_generator V;
/* MAIN BLOCK: GENERATE SERVER FILE
========== ====================
*/
if (!file_open(&op_file, &ser_name, rewriting)) {
error(cant_opn_server);
return;
}
omode = server_mode;
client = false;
fragmentation_used = false;
if (omode == pils)
server_generator_pils();
else if (omode == vaxfor)
server_gen_for();
else {
/** Generate module name and type, var, procedure inclusion **/
if (((1L << ((long)omode)) & (1L << ((long)monolith))) == 0)
gen_module(&op_file);
/* Special INTERFACE part for PCTurbo and MacTurbo:
*/
if (((1L << ((long)omode)) &
((1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0) {
fprintf(op_file, "PROCEDURE attach_");
write_name(&op_file, &unitname);
fprintf(op_file, ";\n");
/* For PCTurbo we must declare the main server procedure in the
INTERFACE part in order to force generation of FAR model code.
This is necessary because it will be called FAR by
Call_Local_Stub.
*/
if (omode == pcturbo) {
fprintf(op_file, "PROCEDURE r_");
write_name(&op_file, &unitname);
fprintf(op_file, "(VAR rpc_p_buf : rpc_message_pointer);\n");
}
fprintf(op_file, "\nIMPLEMENTATION\n\n");
}
/* For MacTurbo and PCTurbo the global procedure
headings must appear in the interface part.
*/
/* Declare the attach procedure. */
/** Generate the jump table for the server **/
gen_jump_proc(&V);
/** Generate the attach procedure **/
if (((1L << ((long)omode)) & (1L << ((long)m6809))) == 0)
gen_attach_(&V);
/** this can't handle procedure parameters **/
/** Generate end of module **/
if (((1L << ((long)omode)) & ((1L << ((long)vaxvms)) | (1L << ((long)vaxpas)) |
(1L << ((long)pcturbo)) | (1L << ((long)macturbo)))) != 0)
fprintf(op_file, "END .\n");
else if (omode == m6809)
fprintf(op_file, "MODEND .\n");
else if (omode == cerncross)
fprintf(op_file, ".\n");
}
if (!file_close(&op_file))
error(cant_cls_server);
if (fragmentation_used)
printf("Buffer fragmentation may be used for large parameters.\n");
/*if not pils or vaxfor*/
} /*SERVER_GENERATOR*/
/* Main Program
------------
*/
main(argc, argv)
int argc;
Char *argv[];
{ /*MAIN*/
PASCAL_MAIN(argc, argv);
op_file = NULL;
inp_file = NULL;
init_global(); /** Global initialization **/
get_parameters(); /** Get command line parameters **/
parser(); /** Parse input **/
if (!file_close(&inp_file)) /** Close input file **/
error(cant_cls_input);
if (!runoptions[(long)version - (long)ccerncross].value)
{ /** Generate stub version number **/
version_num = checksum + 1000;
printf("RPCC: generated stub version number is %ld.\n", version_num);
}
if (runoptions[(long)dtree - (long)ccerncross].value)
{ /** Debugging : print trees **/
print_tab_types();
print_tab_blocks();
} else if (!(ser_spec || cli_spec))
printf("RPCC: no stubs specified - no code generated, hope that's okay.\n");
if (errorfound > 0) { /** Exit gracefully on error **/
printf("RPCC: %3ld errors found, no code generated.\n", errorfound);
_Escape(0);
}
/* Generate client stubs and .ext files */
if (cli_spec) {
client_generator(cli_mode, cli_name);
ext_generator(cli_mode, ext_name);
}
/* Generate server stubs */
if (ser_spec)
server_generator(ser_mode, ser_name);
if (inp_file != NULL)
fclose(inp_file);
if (op_file != NULL)
fclose(op_file);
exit(0);
} /*MAIN*/
/* End. */