/*
** Code derived from program rpc_compiler
*/
extern void exit();
/*
** Definitions for i/o
*/
# include <stdio.h>
typedef struct {
FILE *fp;
unsigned short eoln:1,
eof:1,
out:1,
init:1,
:12;
char buf;
} text;
text input = { stdin, 0, 0 };
text output = { stdout, 0, 0 };
# define Fread(x, f) fread((char *)&x, sizeof(x), 1, f)
# define Get(f) Fread((f).buf, (f).fp)
# define Getx(f) (f).init = 1, (f).eoln = (((f).buf = fgetc((f).fp)) == '\n') ? (((f).buf = ' '), 1) : 0
# define Getchr(f) (f).buf, Getx(f)
static FILE *Tmpfil;
static long Tmplng;
static double Tmpdbl;
# define Fscan(f) (f).init ? ungetc((f).buf, (f).fp) : 0, Tmpfil = (f).fp
# define Scan(p, a) Scanck(fscanf(Tmpfil, p, a))
void Scanck();
void Getl();
# define Eoln(f) ((f).eoln ? true : false)
# define Eof(f) ((((f).init == 0) ? (Get(f)) : 0, ((f).eof ? 1 : feof((f).fp))) ? true : false)
# define Eofx(f) ((((f).init == 0) ? (Getx(f)) : 0, ((f).eof ? 1 : feof((f).fp))) ? true : false)
# define Fwrite(x, f) fwrite((char *)&x, sizeof(x), 1, f)
# define Put(f) Fwrite((f).buf, (f).fp)
# define Putx(f) (f).eoln = ((f).buf == '\n'), (void)fputc((f).buf, (f).fp)
# define Putchr(c, f) (f).buf = (c), Putx(f)
# define Putl(f, v) (f).eoln = v
# define Finish(f) ((f).out && !(f).eoln) ? (Putchr('\n', f), 0) : 0, !fseek((f).fp, 0L, 0)
extern int fseek();
# ifdef READONLY
static char Rmode[] = "r";
# else
static char Rmode[] = "r+";
# endif
# define Reset(f, n, l) (f).init = (f).init ? !fseek((f).fp, 0L, 0) : (((f).fp = Fopen(n, l, Rmode)), 1), (f).eof = (f).out = 0, Get(f)
# define Resetx(f, n, l) (f).init = (f).init ? (Finish(f)) : (((f).fp = Fopen(n, l, Rmode)), 1), (f).eof = (f).out = 0, Getx(f)
# ifdef WRITEONLY
static char Wmode[] = "w";
# else
static char Wmode[] = "w+";
# endif
# define Rewrite(f, n, l) (f).init = (f).init ? !fseek((f).fp, 0L, 0) : (((f).fp = Fopen(n, l, Wmode)), 1), (f).out = (f).eof = 1
# define Rewritex(f, n, l) (f).init = (f).init ? (Finish(f)) : (((f).fp = Fopen(n, l, Wmode)), 1), (f).out = (f).eof = (f).eoln = 1
FILE *Fopen();
# ifndef MAXFILENAME
# define MAXFILENAME 128
# endif
/*
** Definitions for case-statements
** and for non-local gotos
*/
# define Line __LINE__
void Caseerror();
/*
** Definitions for standard types
*/
extern int strncmp();
# define Cmpstr(x, y) strncmp((x), (y), sizeof(x))
typedef char boolean;
# define false (boolean)0
# define true (boolean)1
extern char *Bools[];
typedef int integer;
# define maxint 2147483647
extern void abort();
/*
** Definitions for pointers
*/
# ifndef Unionoffs
# define Unionoffs(p, m) (((long)(&(p)->m))-((long)(p)))
# endif
# define NIL 0
extern char *malloc();
extern void free();
/*
** Definitions for set-operations
*/
# define Claimset() (void)Currset(0, (setptr)0)
# define Newset() Currset(1, (setptr)0)
# define Saveset(s) Currset(2, s)
# define setbits 15
typedef unsigned short setword;
typedef setword * setptr;
boolean Member(), Le(), Ge(), Eq(), Ne();
setptr Union(), Diff();
setptr Insmem(), Mksubr();
setptr Currset(), Inter();
static setptr Tmpset;
extern setptr Conset[];
void Setncpy();
# ifndef SETALIGN
# define SETALIGN(x) Alignset(x)
struct Set { unsigned short S[15+1]; } *Alignset();
# endif
# ifndef STRALIGN
# define STRALIGN(x) Alignstr(x)
struct String { char A[127+1]; } *Alignstr();
# endif
extern char *strncpy();
/*
** Definitions for argv-operations
*/
int argc;
char **argv;
void
Argvgt(n, cp, l)
int n;
register int l;
register char *cp;
{
register char *sp;
for (sp = argv[n]; l > 0 && *sp; l--)
*cp++ = *sp++;
while (l-- > 0)
*cp++ = ' ';
}
/*
** Start of program definitions
*/
# define rpc_name_length 40
# define maxstring 255
# define expression_length 80
# define template_length 10
# define error_length 48
# define maxidlen 25
# define numkeyword 27
# define numomodes 11
# define maxdim 9
# define non_fragmentation_limit 1488
# define fragmentation_threshold 150
# define rpc_default_timeout -1
# define commandline true
typedef struct { char A[maxstring - 1 + 1]; } longstring;
typedef struct { char A[maxidlen - 1 + 1]; } char_name;
typedef struct { char A[3 - 1 + 1]; } char3;
typedef struct { char A[10 - 1 + 1]; } opt_name;
typedef struct { char A[template_length - 1 + 1]; } template_type;
typedef struct { char A[error_length - 1 + 1]; } error_string;
typedef struct S103 {
struct { char A[maxstring - 1 + 1]; } str;
integer len;
} astring;
typedef struct S104 {
struct { char A[maxstring - 1 + 1]; } str;
integer start, len;
} pilstring;
typedef struct S102 {
char_name str;
integer len;
} id_name;
typedef struct S106 {
struct { char A[expression_length - 1 + 1]; } str;
integer len;
} expression;
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, E1_C33_return, pragmatok, nultok } type_token;
typedef struct S105 {
type_token kind;
union {
struct {
id_name name;
} V2;
struct {
integer value;
} V3;
} U;
} token_descriptor;
typedef type_token courier_type;
typedef type_token simple_type;
typedef type_token block_type;
typedef type_token attr_type;
typedef struct S75 * ptr_defined_type;
typedef struct S76 * ptr_named_type;
typedef struct S77 * ptr_idlist;
typedef struct S78 * ptr_block_table;
typedef struct S75 {
ptr_named_type typ_name;
integer typ_min_size;
integer typ_max_size;
integer typ_nesting;
ptr_defined_type typ_subtype;
boolean typ_external;
courier_type typ_basic_type;
union {
struct {
integer typ_low, typ_high;
} V4;
struct {
ptr_named_type typ_fields;
} V5;
} U;
} defined_type;
typedef struct S76 {
ptr_named_type nty_next;
id_name nty_name;
ptr_defined_type nty_type;
} named_type;
typedef struct S77 {
ptr_idlist next;
id_name name;
attr_type attr;
ptr_defined_type id_type;
} id_list;
typedef struct S78 {
ptr_block_table next;
id_name name;
block_type b_type;
simple_type C33_return;
ptr_idlist list;
boolean in_only;
integer blk_nesting;
integer blk_min_in, blk_max_in;
integer blk_min_out, blk_max_out;
integer blk_timeout;
ptr_idlist blk_status_param;
boolean blk_concurrent, blk_cast;
} block_table;
typedef enum { ill_basic_type, number_req, oftok_miss, simtype_req,
blocks_req, ident_req, twice_declared, semicol_miss,
var_attr_req, colon_miss, id_not_declared, clsround_miss,
opnround_miss, package_miss, endtok_miss, char_ignored,
params_miss, input_miss, comma_miss, semic_round_miss,
toomany_dim, toomany_dig, proc_exp, cant_opn_input,
cant_opn_client, cant_opn_server, cant_cls_client, cant_cls_server,
dot_miss, positive_req, cant_cls_input, ident_reserved,
istok_miss, record_miss, invalid_range, bad_proc_decl,
bad_name, type_miss, return_miss, cant_opn_ext,
internal_error, bad_input_name, cant_cls_ext, unexp_eof } err_type;
typedef struct { setword S[4]; } set_of_token;
typedef enum { rewriting, resetting } open_mode;
typedef enum { cerncross, m6809, monolith, vaxvms,
vaxpas, unixbsd, pcturbo, macturbo,
pils, vaxfor, genericc } output_mode;
typedef enum { ccerncross, cm6809, cmonolith, cvaxvms,
cvaxpas, cunixbsd, cpcturbo, cmacturbo,
cpils, cvaxfor, cgenericc, scerncross,
sm6809, smonolith, svaxvms, svaxpas,
sunixbsd, spcturbo, smacturbo, spils,
svaxfor, sgenericc, dlex, dlexhot,
dtree, shortint, stdescr, concurrent,
noautoinit, byvalue, timeout, version,
types, invalid } options;
typedef options rangeoptions;
typedef struct { struct {
char_name name;
type_token symbol;
} A[numkeyword - 1 + 1]; } T79;
typedef struct { struct { char A[3 - 1 + 1]; } A[2]; } T80;
typedef struct { ptr_defined_type A[(int)(longtok) + 1]; } T81;
typedef struct { struct {
opt_name name;
boolean value;
} A[(int)(invalid) + 1]; } T82;
ptr_block_table *G141_scan;
ptr_idlist *G139_scanlist;
integer *G137_proc_number;
text *G135_where;
boolean *G133_doing_externals;
text *G131_where;
boolean *G129_check_subtypes;
integer *G127_original_size;
boolean *G125_check_size;
boolean *G123_topack;
integer *G121_level;
text *G119_where;
ptr_block_table *G117_scan;
integer *G115_proc_number;
ptr_block_table *G113_scan;
integer *G111_proc_number;
integer *G109_col;
ptr_idlist *G107_headlist;
ptr_named_type typeptr;
ptr_block_table blockptr;
id_name unitname;
integer checksum;
boolean is_blank;
char ch_there;
char lastcar;
char oldchar;
boolean char_ready;
boolean incomment;
integer lastindex;
token_descriptor token, lastoken;
boolean tok_present;
integer lineread;
integer maxkeyword;
T79 keyword;
T80 upkpck;
T81 simple_descriptor;
boolean external_marshalling;
integer number_of_invented_types;
integer errorfound;
text inp_file;
astring inp_name;
pilstring inp_line;
text op_file;
astring cli_name;
astring ser_name;
astring ext_name;
integer next_label;
integer size_so_far;
boolean fragmentation_used;
boolean deref, dr_tmp;
boolean cli_spec, ser_spec;
output_mode omode, ser_mode, cli_mode;
boolean client;
struct { setword S[2]; } cmode;
integer timeout_val;
integer version_num;
T82 runoptions;
void getoken();
void backtoken();
void
error(which)
err_type which;
{
(void)fprintf(output.fp, "ERROR: "), Putl(output, 0);
errorfound = errorfound + 1;
if (!(Member((unsigned)(which), Conset[0])))
(void)fprintf(output.fp, "RPCC: Panic: compiler internal error, notify the compiler's Administrator.\n"), Putl(output, 1);
else
switch ((int)(which)) {
case ill_basic_type:
(void)fprintf(output.fp, "Illegal basic type.\n"), Putl(output, 1);
break ;
case invalid_range:
(void)fprintf(output.fp, "Upper bound must be greater then lower.\n"), Putl(output, 1);
break ;
case number_req:
(void)fprintf(output.fp, "Number requested.\n"), Putl(output, 1);
break ;
case oftok_miss:
(void)fprintf(output.fp, "Keyword \"of\" missing.\n"), Putl(output, 1);
break ;
case simtype_req:
(void)fprintf(output.fp, "Simple type requested.\n"), Putl(output, 1);
break ;
case positive_req:
(void)fprintf(output.fp, "Index must be positive.\n"), Putl(output, 1);
break ;
case ident_req:
(void)fprintf(output.fp, "Identifier requested.\n"), Putl(output, 1);
break ;
case blocks_req:
(void)fprintf(output.fp, "At least a procedure/function declaration requested.\n"), Putl(output, 1);
break ;
case bad_proc_decl:
(void)fprintf(output.fp, "Parameter must be simple or already declared in type section.\n"), Putl(output, 1);
break ;
case twice_declared:
(void)fprintf(output.fp, "Identifier already declared.\n"), Putl(output, 1);
break ;
case semicol_miss:
(void)fprintf(output.fp, "Semicolon \";\" missing.\n"), Putl(output, 1);
break ;
case semic_round_miss:
(void)fprintf(output.fp, "Semicolon \";\" or round bracket \")\" missing.\n"), Putl(output, 1);
break ;
case comma_miss:
(void)fprintf(output.fp, "Comma \",\" missing.\n"), Putl(output, 1);
break ;
case var_attr_req:
(void)fprintf(output.fp, "\"in\",\"out\" or \"in out\" required.\n"), Putl(output, 1);
break ;
case colon_miss:
(void)fprintf(output.fp, "Colon \":\" missing.\n"), Putl(output, 1);
break ;
case dot_miss:
(void)fprintf(output.fp, "Dot \".\" missing.\n"), Putl(output, 1);
break ;
case id_not_declared:
(void)fprintf(output.fp, "Identifier not declared.\n"), Putl(output, 1);
break ;
case clsround_miss:
(void)fprintf(output.fp, "Round bracket \")\" missing.\n"), Putl(output, 1);
break ;
case opnround_miss:
(void)fprintf(output.fp, "Round bracket \"(\" missing.\n"), Putl(output, 1);
break ;
case package_miss:
(void)fprintf(output.fp, "Keyword \"package\" missing.\n"), Putl(output, 1);
break ;
case record_miss:
(void)fprintf(output.fp, "Keyword \"record\" missing.\n"), Putl(output, 1);
break ;
case return_miss:
(void)fprintf(output.fp, "Keyword \"return\" missing.\n"), Putl(output, 1);
break ;
case istok_miss:
(void)fprintf(output.fp, "Keyword \"is\" missing.\n"), Putl(output, 1);
break ;
case endtok_miss:
(void)fprintf(output.fp, "Keyword \"end\" missing.\n"), Putl(output, 1);
break ;
case type_miss:
(void)fprintf(output.fp, "Keyword \"type\", \"procedure\" or \"function\" missing.\n"), Putl(output, 1);
break ;
case char_ignored:
(void)fprintf(output.fp, "Illegal character:\"%c\", ignored.\n", lastcar), Putl(output, 1);
break ;
case toomany_dig:
(void)fprintf(output.fp, "Too many digits in this number.\n"), Putl(output, 1);
break ;
case toomany_dim:
(void)fprintf(output.fp, "Too many dimensions in this array.\n"), Putl(output, 1);
break ;
case ident_reserved:
(void)fprintf(output.fp, "Identifier reserved for compiler use.\n"), Putl(output, 1);
break ;
case bad_name:
(void)fprintf(output.fp, "Identifier does not match already declared package name.\n"), Putl(output, 1);
break ;
case proc_exp:
(void)fprintf(output.fp, "Keyword \"procedure\" or \"function\" expected.\n"), Putl(output, 1);
break ;
case params_miss:
(void)fprintf(output.fp, "Parameters missing.\n"), Putl(output, 1);
break ;
case input_miss:
(void)fprintf(output.fp, "Input file missing, can't go on.\n"), Putl(output, 1);
break ;
case bad_input_name:
(void)fprintf(output.fp, "Bad input file name: \".ext\" extension reserved.\n"), Putl(output, 1);
break ;
case cant_opn_input:
(void)fprintf(output.fp, "Can't open input file.\n"), Putl(output, 1);
break ;
case cant_opn_ext:
(void)fprintf(output.fp, "Can't open \".ext\" file.\n"), Putl(output, 1);
break ;
case cant_opn_client:
(void)fprintf(output.fp, "Can't open client file.\n"), Putl(output, 1);
break ;
case cant_opn_server:
(void)fprintf(output.fp, "Can't open server file.\n"), Putl(output, 1);
break ;
case cant_cls_input:
(void)fprintf(output.fp, "Can't close input file.\n"), Putl(output, 1);
break ;
case cant_cls_client:
(void)fprintf(output.fp, "Can't close client file.\n"), Putl(output, 1);
break ;
case cant_cls_server:
(void)fprintf(output.fp, "Can't close server file.\n"), Putl(output, 1);
break ;
case cant_cls_ext:
(void)fprintf(output.fp, "Can't close \".ext\" file.\n"), Putl(output, 1);
break ;
case internal_error:
(void)fprintf(output.fp, "Sorry - Unexpected internal condition in compiler.\n"), Putl(output, 1);
break ;
case unexp_eof:
(void)fprintf(output.fp, "Unexpected end of input file.\n"), Putl(output, 1);
break ;
default:
Caseerror(Line);
}
}
void
write_token(what)
type_token what;
{
if (!(Member((unsigned)(what), Conset[1])))
(void)fprintf(output.fp, "(Unknown token!)"), Putl(output, 0);
else
switch ((int)(what)) {
case chartok:
(void)fprintf(output.fp, "RPC_CHAR"), Putl(output, 0);
break ;
case bytetok:
(void)fprintf(output.fp, "RPC_BYTE"), Putl(output, 0);
break ;
case shortok:
(void)fprintf(output.fp, "RPC_SHORT"), Putl(output, 0);
break ;
case integertok:
(void)fprintf(output.fp, "RPC_INTEGER"), Putl(output, 0);
break ;
case real32tok:
(void)fprintf(output.fp, "RPC_REAL32"), Putl(output, 0);
break ;
case real48tok:
(void)fprintf(output.fp, "RPC_REAL48"), Putl(output, 0);
break ;
case real64tok:
(void)fprintf(output.fp, "RPC_REAL64"), Putl(output, 0);
break ;
case real128tok:
(void)fprintf(output.fp, "RPC_REAL128"), Putl(output, 0);
break ;
case longtok:
(void)fprintf(output.fp, "RPC_LONG"), Putl(output, 0);
break ;
case arraytok:
(void)fprintf(output.fp, "ARRAY"), Putl(output, 0);
break ;
case sequence:
(void)fprintf(output.fp, "SEQUENCE"), Putl(output, 0);
break ;
case stringtok:
(void)fprintf(output.fp, "STRING"), Putl(output, 0);
break ;
case substring:
(void)fprintf(output.fp, "SUBSTRING"), Putl(output, 0);
break ;
case package:
(void)fprintf(output.fp, "PACKAGE"), Putl(output, 0);
break ;
case semicolon:
(void)fprintf(output.fp, "SEMICOLON"), Putl(output, 0);
break ;
case typetok:
(void)fprintf(output.fp, "TYPE"), Putl(output, 0);
break ;
case endtok:
(void)fprintf(output.fp, "END"), Putl(output, 0);
break ;
case colon:
(void)fprintf(output.fp, "colon \":\""), Putl(output, 0);
break ;
case comma:
(void)fprintf(output.fp, "comma \",\""), Putl(output, 0);
break ;
case opnround:
(void)fprintf(output.fp, "\"(\""), Putl(output, 0);
break ;
case clsround:
(void)fprintf(output.fp, "\")\""), Putl(output, 0);
break ;
case oftok:
(void)fprintf(output.fp, "OF"), Putl(output, 0);
break ;
case intok:
(void)fprintf(output.fp, "IN"), Putl(output, 0);
break ;
case outok:
(void)fprintf(output.fp, "OUT"), Putl(output, 0);
break ;
case inoutok:
(void)fprintf(output.fp, "INOUT"), Putl(output, 0);
break ;
case istok:
(void)fprintf(output.fp, "IS"), Putl(output, 0);
break ;
case E1_C33_return:
(void)fprintf(output.fp, "RETURN"), Putl(output, 0);
break ;
case dot:
(void)fprintf(output.fp, "\".\""), Putl(output, 0);
break ;
case ident:
(void)fprintf(output.fp, "identifier"), Putl(output, 0);
break ;
case number:
(void)fprintf(output.fp, "number"), Putl(output, 0);
break ;
case proctok:
(void)fprintf(output.fp, "PROCEDURE"), Putl(output, 0);
break ;
case functok:
(void)fprintf(output.fp, "FUNCTION "), Putl(output, 0);
break ;
case nultok:
(void)fprintf(output.fp, "(Null Token!)"), Putl(output, 0);
break ;
default:
Caseerror(Line);
}
}
void
print_last_line()
{
register integer a;
(void)fprintf(output.fp, "INPUT:"), Putl(output, 0);
{
integer B6 = 1,
B7 = inp_line.len;
if (B6 <= B7)
for (a = B6; ; a++) {
Putchr(inp_line.str.A[a - 1], output);
if (a == B7) break;
}
}
Putchr('\n', output);
{
integer B8 = 1,
B9 = lastindex + 4;
if (B8 <= B9)
for (a = B8; ; a++) {
Putchr('-', output);
if (a == B9) break;
}
}
Putchr('^', output);
Putchr('\n', output);
}
void
linerror(which)
err_type which;
{
(void)fprintf(output.fp, "RPCC: Error found on line %3d:\n", lineread), Putl(output, 1);
print_last_line();
error(which);
Putchr('\n', output);
}
void
find_tok(kind)
set_of_token kind;
{
while (!(Member((unsigned)(token.kind), kind.S)))
getoken();
}
void
errfind(which, kind)
err_type which;
set_of_token kind;
{
linerror(which);
find_tok(kind);
}
void
abort_pgm(which)
err_type which;
{
error(which);
(void)fprintf(output.fp, "Fatal error, program aborted.\n"), Putl(output, 1);
abort();
}
void
debug_print_name(where, name)
text *where;
id_name name;
{
register integer i;
{
register struct S102 *W10 = &name;
{
integer B11 = 1,
B12 = W10->len;
if (B11 <= B12)
for (i = B11; ; i++) {
Putchr(W10->str.A[i - 1], (*where));
if (i == B12) break;
}
}
}
}
void
printok(what)
type_token what;
{
if (!(Member((unsigned)(what), Conset[2])))
(void)fprintf(output.fp, "?????? (bad type token) ???"), Putl(output, 0);
else
switch ((int)(what)) {
case chartok:
(void)fprintf(output.fp, "RPC_CHAR"), Putl(output, 0);
break ;
case bytetok:
(void)fprintf(output.fp, "RPC_BYTE"), Putl(output, 0);
break ;
case shortok:
(void)fprintf(output.fp, "RPC_SHORT"), Putl(output, 0);
break ;
case integertok:
(void)fprintf(output.fp, "RPC_INTEGER"), Putl(output, 0);
break ;
case real32tok:
(void)fprintf(output.fp, "RPC_REAL32"), Putl(output, 0);
break ;
case real48tok:
(void)fprintf(output.fp, "RPC_REAL48"), Putl(output, 0);
break ;
case real64tok:
(void)fprintf(output.fp, "RPC_REAL64"), Putl(output, 0);
break ;
case real128tok:
(void)fprintf(output.fp, "RPC_REAL128"), Putl(output, 0);
break ;
case longtok:
(void)fprintf(output.fp, "RPC_LONG"), Putl(output, 0);
break ;
case arraytok:
(void)fprintf(output.fp, "ARRAY"), Putl(output, 0);
break ;
case sequence:
(void)fprintf(output.fp, "SEQUENCE"), Putl(output, 0);
break ;
case stringtok:
(void)fprintf(output.fp, "STRING"), Putl(output, 0);
break ;
case substring:
(void)fprintf(output.fp, "SUBSTRING"), Putl(output, 0);
break ;
case package:
(void)fprintf(output.fp, "PACKAGE"), Putl(output, 0);
break ;
case semicolon:
(void)fprintf(output.fp, "SEMICOLON"), Putl(output, 0);
break ;
case typetok:
(void)fprintf(output.fp, "TYPE"), Putl(output, 0);
break ;
case endtok:
(void)fprintf(output.fp, "END"), Putl(output, 0);
break ;
case colon:
(void)fprintf(output.fp, "COLON"), Putl(output, 0);
break ;
case comma:
(void)fprintf(output.fp, "COMMA"), Putl(output, 0);
break ;
case opnround:
(void)fprintf(output.fp, "OPNROUND"), Putl(output, 0);
break ;
case clsround:
(void)fprintf(output.fp, "CLSROUND"), Putl(output, 0);
break ;
case oftok:
(void)fprintf(output.fp, "OF"), Putl(output, 0);
break ;
case intok:
(void)fprintf(output.fp, "IN "), Putl(output, 0);
break ;
case outok:
(void)fprintf(output.fp, "OUT "), Putl(output, 0);
break ;
case inoutok:
(void)fprintf(output.fp, "IN OUT "), Putl(output, 0);
break ;
case istok:
(void)fprintf(output.fp, "IS"), Putl(output, 0);
break ;
case E1_C33_return:
(void)fprintf(output.fp, "RETURN"), Putl(output, 0);
break ;
case dot:
(void)fprintf(output.fp, "DOT"), Putl(output, 0);
break ;
case ident:
(void)fprintf(output.fp, "IDENT"), Putl(output, 0);
break ;
case number:
(void)fprintf(output.fp, "NUMBER"), Putl(output, 0);
break ;
case proctok:
(void)fprintf(output.fp, "PROCEDURE"), Putl(output, 0);
break ;
case functok:
(void)fprintf(output.fp, "FUNCTION "), Putl(output, 0);
break ;
case nultok:
(void)fprintf(output.fp, "NULTOKEN"), Putl(output, 0);
break ;
default:
Caseerror(Line);
}
}
integer
indent(level)
integer level;
{
register integer R84;
R84 = level * 4 + 16;
return R84;
}
void
print_def_type(ptr, level)
ptr_defined_type ptr;
integer level;
{
integer a;
ptr_named_type scan;
if (ptr == (struct S75 *)NIL)
(void)fprintf(output.fp, "???? NIL pointer ????"), Putl(output, 0);
else
if (!(Member((unsigned)(ptr->typ_basic_type), Conset[3])))
(void)fprintf(output.fp, "???? Bad basic type ????"), Putl(output, 0);
else
{
register struct S75 *W13 = &(*ptr);
if (((level > 1) || (Member((unsigned)(W13->typ_basic_type), Conset[4]))) && (W13->typ_name != (struct S76 *)NIL)) {
(void)fprintf(output.fp, "%*c", indent(level), ' '), Putl(output, 0);
debug_print_name(&output, W13->typ_name->nty_name);
Putchr(';', output),Putchr('\n', output);
} else
switch ((int)(W13->typ_basic_type)) {
case chartok: case bytetok: case shortok: case integertok:
case real32tok: case real48tok: case real64tok: case real128tok:
case longtok:
(void)fprintf(output.fp, "%*c", indent(level), ' '), Putl(output, 0);
printok(W13->typ_basic_type);
(void)fprintf(output.fp, "; -- ??? unnamed basic type ???\n"), Putl(output, 1);
break ;
case stringtok:
(void)fprintf(output.fp, "%*cSTRING (%1d);\n", indent(level), ' ', W13->U.V4.typ_high), Putl(output, 1);
break ;
case arraytok:
(void)fprintf(output.fp, "%*cARRAY (%1d..%1d) OF\n", indent(level), ' ', W13->U.V4.typ_low, W13->U.V4.typ_high), Putl(output, 1);
print_def_type(W13->typ_subtype, level + 1);
break ;
case accesstok:
(void)fprintf(output.fp, "%*cACCESS\n", indent(level), ' '), Putl(output, 1);
print_def_type(W13->typ_subtype, level + 1);
break ;
case recordtok:
(void)fprintf(output.fp, "%*cRECORD\n", indent(level), ' '), Putl(output, 1);
scan = W13->U.V5.typ_fields;
while (scan != (struct S76 *)NIL)
{
register struct S76 *W14 = &(*scan);
(void)fprintf(output.fp, "%*c", indent(level + 1), ' '), Putl(output, 0);
debug_print_name(&output, W14->nty_name);
(void)fprintf(output.fp, ": \n"), Putl(output, 1);
print_def_type(W14->nty_type, level + 2);
scan = scan->nty_next;
}
(void)fprintf(output.fp, "%*cEND RECORD;\n", indent(level), ' '), Putl(output, 1);
break ;
case sequence:
(void)fprintf(output.fp, "%*cSEQUENCE (%1d) OF \n", indent(level), ' ', W13->U.V4.typ_high), Putl(output, 1);
print_def_type(W13->typ_subtype, level + 1);
break ;
case substring:
(void)fprintf(output.fp, "%*cSUBSTRING (%1d);\n", indent(level), ' ', W13->U.V4.typ_high), Putl(output, 1);
break ;
default:
Caseerror(Line);
}
}
}
void
print_tab_types()
{
ptr_named_type scan;
register options a;
Putchr('\n', output);
(void)fprintf(output.fp, "-- Compiler options requested:\n"), Putl(output, 1);
Putchr('\n', output);
{
options B15 = ccerncross,
B16 = invalid;
if ((int)(B15) <= (int)(B16))
for (a = B15; ; a = (options)((int)(a)+1)) {
if (runoptions.A[(int)(a)].value)
(void)fprintf(output.fp, "-- Option %.10s is set.\n", runoptions.A[(int)(a)].name.A), Putl(output, 1);
if (a == B16) break;
}
}
Putchr('\n', output);
Putchr('\n', output);
(void)fprintf(output.fp, "-- Tree of types (alphabetical order)\n"), Putl(output, 1);
Putchr('\n', output);
scan = typeptr;
while (scan != (struct S76 *)NIL) {
(void)fprintf(output.fp, "TYPE "), Putl(output, 0);
debug_print_name(&output, scan->nty_name);
(void)fprintf(output.fp, " IS \n"), Putl(output, 1);
print_def_type(scan->nty_type, 1);
{
register struct S75 *W17 = &(*scan->nty_type);
if (W17->typ_max_size == W17->typ_min_size)
(void)fprintf(output.fp, " -- Representation: %1d bytes.\n", W17->typ_max_size), Putl(output, 1);
else
(void)fprintf(output.fp, " -- Representation: %1d bytes minimum, %1d bytes maximum.\n", W17->typ_min_size, W17->typ_max_size), Putl(output, 1);
}
Putchr('\n', output);
scan = scan->nty_next;
}
}
void print_tab_blocks();
void
print_list(ptr)
ptr_idlist ptr;
{
(void)fprintf(output.fp, "with parameters:\n"), Putl(output, 1);
do {
(void)fprintf(output.fp, " %.25s : ", ptr->name.str.A), Putl(output, 0);
printok(ptr->attr);
if (ptr->id_type->typ_name != (struct S76 *)NIL)
(void)fprintf(output.fp, "%.25s", ptr->id_type->typ_name->nty_name.str.A), Putl(output, 0);
else
print_def_type(ptr->id_type, 1);
Putchr('\n', output);
ptr = ptr->next;
} while (!(ptr == (struct S77 *)NIL));
(void)fprintf(output.fp, "(end of parameters)"), Putl(output, 0);
}
void
print_tab_blocks()
{
ptr_block_table scan;
Putchr('\n', output);
(void)fprintf(output.fp, "################## TREE OF BLOCKS #######################\n"), Putl(output, 1);
Putchr('\n', output);
(void)fprintf(output.fp, "PACKAGE %.25s IS\n", unitname.str.A), Putl(output, 1);
scan = blockptr;
while (scan != (struct S78 *)NIL) {
Putchr('\n', output);
printok(scan->b_type);
(void)fprintf(output.fp, " %.25s", scan->name.str.A), Putl(output, 0);
if (scan->list != (struct S77 *)NIL)
print_list(scan->list);
if (scan->b_type == functok) {
(void)fprintf(output.fp, " RETURN "), Putl(output, 0);
printok(scan->C33_return);
}
Putchr('\n', output);
(void)fprintf(output.fp, "-- Minimum %1d bytes in, %1d out.\n", scan->blk_min_in, scan->blk_min_out), Putl(output, 1);
(void)fprintf(output.fp, "-- Maximum %1d bytes in, %1d out.\n", scan->blk_max_in, scan->blk_max_out), Putl(output, 1);
(void)fprintf(output.fp, "-- _______________________________________________________\n"), Putl(output, 1);
scan = scan->next;
}
(void)fprintf(output.fp, "END %.25s;\n", unitname.str.A), Putl(output, 1);
Putchr('\n', output);
}
void
print_token()
{
(void)fprintf(output.fp, " Token read: "), Putl(output, 0);
if (token.kind == ident)
(void)fprintf(output.fp, "IDENT:\"%.25s\"", token.U.V2.name.str.A), Putl(output, 0);
else
if (token.kind == number)
(void)fprintf(output.fp, "NUMBER: %10d", token.U.V3.value), Putl(output, 0);
else
printok(token.kind);
Putchr('\n', output);
}
void getoken_init();
void
put_keyword(name, tok)
char_name name;
type_token tok;
{
maxkeyword = maxkeyword + 1;
keyword.A[maxkeyword - 1].name = name;
keyword.A[maxkeyword - 1].symbol = tok;
}
void
getoken_init()
{
inp_line.len = 0;
inp_line.start = 0;
lastindex = 1;
lineread = 0;
tok_present = false;
lastcar = ' ';
char_ready = false;
incomment = false;
maxkeyword = 0;
put_keyword(*((char_name *)STRALIGN("access ")), accesstok);
put_keyword(*((char_name *)STRALIGN("array ")), arraytok);
put_keyword(*((char_name *)STRALIGN("end ")), endtok);
put_keyword(*((char_name *)STRALIGN("function ")), functok);
put_keyword(*((char_name *)STRALIGN("in ")), intok);
put_keyword(*((char_name *)STRALIGN("inout ")), inoutok);
put_keyword(*((char_name *)STRALIGN("is ")), istok);
put_keyword(*((char_name *)STRALIGN("of ")), oftok);
put_keyword(*((char_name *)STRALIGN("out ")), outok);
put_keyword(*((char_name *)STRALIGN("package ")), package);
put_keyword(*((char_name *)STRALIGN("pragma ")), pragmatok);
put_keyword(*((char_name *)STRALIGN("procedure ")), proctok);
put_keyword(*((char_name *)STRALIGN("record ")), recordtok);
put_keyword(*((char_name *)STRALIGN("return ")), E1_C33_return);
put_keyword(*((char_name *)STRALIGN("rpc_byte ")), bytetok);
put_keyword(*((char_name *)STRALIGN("rpc_char ")), chartok);
put_keyword(*((char_name *)STRALIGN("rpc_integer ")), integertok);
put_keyword(*((char_name *)STRALIGN("rpc_long ")), longtok);
put_keyword(*((char_name *)STRALIGN("rpc_real128 ")), real128tok);
put_keyword(*((char_name *)STRALIGN("rpc_real32 ")), real32tok);
put_keyword(*((char_name *)STRALIGN("rpc_real48 ")), real48tok);
put_keyword(*((char_name *)STRALIGN("rpc_real64 ")), real64tok);
put_keyword(*((char_name *)STRALIGN("rpc_short ")), shortok);
put_keyword(*((char_name *)STRALIGN("sequence ")), sequence);
put_keyword(*((char_name *)STRALIGN("string ")), stringtok);
put_keyword(*((char_name *)STRALIGN("substring ")), substring);
put_keyword(*((char_name *)STRALIGN("type ")), typetok);
(void)strncpy(upkpck.A[(int)(false)].A, "upk", sizeof(upkpck.A[(int)(false)].A));
(void)strncpy(upkpck.A[(int)(true)].A, "pck", sizeof(upkpck.A[(int)(true)].A));
}
void
inp_options()
{
register options opt;
{
options B18 = ccerncross,
B19 = invalid;
if ((int)(B18) <= (int)(B19))
for (opt = B18; ; opt = (options)((int)(opt)+1)) {
runoptions.A[(int)(opt)].value = false;
if (opt == B19) break;
}
}
(void)strncpy(runoptions.A[(int)(cmonolith)].name.A, "cmonolith ", sizeof(runoptions.A[(int)(cmonolith)].name.A));
(void)strncpy(runoptions.A[(int)(ccerncross)].name.A, "ccerncross", sizeof(runoptions.A[(int)(ccerncross)].name.A));
(void)strncpy(runoptions.A[(int)(cm6809)].name.A, "cm6809 ", sizeof(runoptions.A[(int)(cm6809)].name.A));
(void)strncpy(runoptions.A[(int)(cvaxvms)].name.A, "cvaxvms ", sizeof(runoptions.A[(int)(cvaxvms)].name.A));
(void)strncpy(runoptions.A[(int)(cvaxpas)].name.A, "cvaxpas ", sizeof(runoptions.A[(int)(cvaxpas)].name.A));
(void)strncpy(runoptions.A[(int)(cunixbsd)].name.A, "cunixbsd ", sizeof(runoptions.A[(int)(cunixbsd)].name.A));
(void)strncpy(runoptions.A[(int)(cpcturbo)].name.A, "cpcturbo ", sizeof(runoptions.A[(int)(cpcturbo)].name.A));
(void)strncpy(runoptions.A[(int)(cmacturbo)].name.A, "cmacturbo ", sizeof(runoptions.A[(int)(cmacturbo)].name.A));
(void)strncpy(runoptions.A[(int)(cpils)].name.A, "cpils ", sizeof(runoptions.A[(int)(cpils)].name.A));
(void)strncpy(runoptions.A[(int)(cvaxfor)].name.A, "cfortran ", sizeof(runoptions.A[(int)(cvaxfor)].name.A));
(void)strncpy(runoptions.A[(int)(cgenericc)].name.A, "cgenericc ", sizeof(runoptions.A[(int)(cgenericc)].name.A));
(void)strncpy(runoptions.A[(int)(smonolith)].name.A, "smonolith ", sizeof(runoptions.A[(int)(smonolith)].name.A));
(void)strncpy(runoptions.A[(int)(scerncross)].name.A, "scerncross", sizeof(runoptions.A[(int)(scerncross)].name.A));
(void)strncpy(runoptions.A[(int)(sm6809)].name.A, "sm6809 ", sizeof(runoptions.A[(int)(sm6809)].name.A));
(void)strncpy(runoptions.A[(int)(svaxvms)].name.A, "svaxvms ", sizeof(runoptions.A[(int)(svaxvms)].name.A));
(void)strncpy(runoptions.A[(int)(svaxpas)].name.A, "svaxpas ", sizeof(runoptions.A[(int)(svaxpas)].name.A));
(void)strncpy(runoptions.A[(int)(sunixbsd)].name.A, "sunixbsd ", sizeof(runoptions.A[(int)(sunixbsd)].name.A));
(void)strncpy(runoptions.A[(int)(spcturbo)].name.A, "spcturbo ", sizeof(runoptions.A[(int)(spcturbo)].name.A));
(void)strncpy(runoptions.A[(int)(smacturbo)].name.A, "smacturbo ", sizeof(runoptions.A[(int)(smacturbo)].name.A));
(void)strncpy(runoptions.A[(int)(spils)].name.A, "spils ", sizeof(runoptions.A[(int)(spils)].name.A));
(void)strncpy(runoptions.A[(int)(svaxfor)].name.A, "sfortran ", sizeof(runoptions.A[(int)(svaxfor)].name.A));
(void)strncpy(runoptions.A[(int)(sgenericc)].name.A, "sgenericc ", sizeof(runoptions.A[(int)(sgenericc)].name.A));
(void)strncpy(runoptions.A[(int)(dlex)].name.A, "dlex ", sizeof(runoptions.A[(int)(dlex)].name.A));
(void)strncpy(runoptions.A[(int)(dlexhot)].name.A, "dlexhot ", sizeof(runoptions.A[(int)(dlexhot)].name.A));
(void)strncpy(runoptions.A[(int)(dtree)].name.A, "dtree ", sizeof(runoptions.A[(int)(dtree)].name.A));
(void)strncpy(runoptions.A[(int)(shortint)].name.A, "shortint ", sizeof(runoptions.A[(int)(shortint)].name.A));
(void)strncpy(runoptions.A[(int)(stdescr)].name.A, "stdescr ", sizeof(runoptions.A[(int)(stdescr)].name.A));
(void)strncpy(runoptions.A[(int)(concurrent)].name.A, "concurrent", sizeof(runoptions.A[(int)(concurrent)].name.A));
(void)strncpy(runoptions.A[(int)(noautoinit)].name.A, "noautoinit", sizeof(runoptions.A[(int)(noautoinit)].name.A));
(void)strncpy(runoptions.A[(int)(byvalue)].name.A, "byvalue ", sizeof(runoptions.A[(int)(byvalue)].name.A));
(void)strncpy(runoptions.A[(int)(timeout)].name.A, "timeout ", sizeof(runoptions.A[(int)(timeout)].name.A));
(void)strncpy(runoptions.A[(int)(version)].name.A, "version ", sizeof(runoptions.A[(int)(version)].name.A));
(void)strncpy(runoptions.A[(int)(types)].name.A, "types ", sizeof(runoptions.A[(int)(types)].name.A));
Setncpy(cmode.S, Conset[5], sizeof(cmode.S));
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;
}
void
pointers_init()
{
typeptr = (struct S76 *)NIL;
blockptr = (struct S78 *)NIL;
}
void
init_global()
{
getoken_init();
inp_options();
pointers_init();
errorfound = 0;
}
void
get_argc(count)
integer *count;
{
(*count) = argc - 1;
}
void
get_argv(what, towhere, len)
integer what;
longstring *towhere;
integer *len;
{
boolean loop;
Argvgt(what, (*towhere).A, sizeof((*towhere).A));
(*len) = 0;
loop = true;
while ((loop) && ((*len) <= maxstring))
if (towhere->A[(*len) + 1 - 1] != ' ')
(*len) = (*len) + 1;
else
loop = false;
}
boolean
file_open(file_des, name, mode)
text *file_des;
astring *name;
open_mode mode;
{
register boolean R85;
register integer a;
longstring str;
{
integer B20 = 1,
B21 = name->len;
if (B20 <= B21)
for (a = B20; ; a++) {
str.A[a - 1] = name->str.A[a - 1];
if (a == B21) break;
}
}
a = name->len;
if (a < maxstring)
a = a + 1;
str.A[a - 1] = 0;
if (mode == rewriting)
Rewritex((*file_des), str.A, sizeof(str.A));
else
Resetx((*file_des), str.A, sizeof(str.A));
R85 = true;
return R85;
}
boolean
file_close(file_des)
text *file_des;
{
register boolean R86;
fflush((*file_des).fp);
R86 = true;
return R86;
}
void
analize(arg, len, interactive)
longstring *arg;
integer len;
boolean interactive;
{
# define magic1 '-'
# define magic2 '-'
opt_name loc_arg;
register integer i;
register integer a;
boolean found;
options scan;
boolean present;
if ((arg->A[1 - 1] == magic1) || (arg->A[1 - 1] == magic2) || (interactive)) {
(void)strncpy(loc_arg.A, " ", sizeof(loc_arg.A));
a = 1;
present = false;
while ((a <= 11) && (a < len) && !present) {
if (arg->A[a + 1 - 1] == '=')
present = true;
else
if (a <= 10) {
if (Member((unsigned)(arg->A[a + 1 - 1]), Conset[6]))
loc_arg.A[a - 1] = (unsigned)('a') + (unsigned)(arg->A[a + 1 - 1]) - (unsigned)('A');
else
loc_arg.A[a - 1] = arg->A[a + 1 - 1];
}
a = a + 1;
}
scan = ccerncross;
found = false;
do {
if (Cmpstr(loc_arg.A, runoptions.A[(int)(scan)].name.A) == 0) {
found = true;
if ((unsigned)(scan) < numomodes) {
if (cli_spec) {
(void)fprintf(output.fp, "RPCC: "), Putl(output, 0);
{
integer B22 = 1,
B23 = len;
if (B22 <= B23)
for (a = B22; ; a++) {
Putchr(arg->A[a - 1], output);
if (a == B23) break;
}
}
(void)fprintf(output.fp, ": client already specified - option ignored.\n"), Putl(output, 1);
} else {
cli_spec = true;
{
integer B24 = 1,
B25 = (unsigned)(scan);
if (B24 <= B25)
for (i = B24; ; i++) {
cli_mode = ((output_mode)((int)(cli_mode)+1));
if (i == B25) break;
}
}
if (present) {
cli_name.len = len - a;
{
integer B26 = 1,
B27 = len - a;
if (B26 <= B27)
for (i = B26; ; i++) {
cli_name.str.A[i - 1] = arg->A[a + i - 1];
if (i == B27) break;
}
}
}
}
} else
if ((unsigned)(scan) < 2 * numomodes) {
if (ser_spec) {
(void)fprintf(output.fp, "RPCC: "), Putl(output, 0);
{
integer B28 = 1,
B29 = len;
if (B28 <= B29)
for (a = B28; ; a++) {
Putchr(arg->A[a - 1], output);
if (a == B29) break;
}
}
(void)fprintf(output.fp, ": server already specified - option ignored.\n"), Putl(output, 1);
} else {
ser_spec = true;
{
integer B30 = 1,
B31 = (unsigned)(scan) - numomodes;
if (B30 <= B31)
for (i = B30; ; i++) {
ser_mode = ((output_mode)((int)(ser_mode)+1));
if (i == B31) break;
}
}
if (present) {
ser_name.len = len - a;
{
integer B32 = 1,
B33 = len - a;
if (B32 <= B33)
for (i = B32; ; i++) {
ser_name.str.A[i - 1] = arg->A[a + i - 1];
if (i == B33) break;
}
}
}
}
} else {
runoptions.A[(int)(scan)].value = true;
if (scan == timeout) {
if (a >= len) {
(void)fprintf(output.fp, "RPCC: timeout value missing, default will be used.\n"), Putl(output, 1);
runoptions.A[(int)(timeout)].value = false;
} else {
timeout_val = 0;
{
integer B34 = 1,
B35 = len - a;
if (B34 <= B35)
for (i = B34; ; i++) {
if (Member((unsigned)(arg->A[a + i - 1]), Conset[7]))
timeout_val = 10 * timeout_val + (unsigned)(arg->A[a + i - 1]) - (unsigned)('0');
else {
(void)fprintf(output.fp, "RPCC timeout option: "), Putl(output, 0);
abort_pgm(number_req);
}
if (i == B35) break;
}
}
if (timeout_val == 0)
(void)fprintf(output.fp, "RPCC: timeout is zero, hope that's okay.\n"), Putl(output, 1);
}
} else
if (scan == version) {
if (a >= len) {
(void)fprintf(output.fp, "RPCC: supplying missing version number.\n"), Putl(output, 1);
runoptions.A[(int)(version)].value = false;
} else {
version_num = 0;
{
integer B36 = 1,
B37 = len - a;
if (B36 <= B37)
for (i = B36; ; i++) {
if (Member((unsigned)(arg->A[a + i - 1]), Conset[8]))
version_num = 10 * version_num + (unsigned)(arg->A[a + i - 1]) - (unsigned)('0');
else {
(void)fprintf(output.fp, "RPCC version option: "), Putl(output, 0);
abort_pgm(number_req);
}
if (i == B37) break;
}
}
if (version_num == 0)
(void)fprintf(output.fp, "RPCC: stub version check disabled.\n"), Putl(output, 1);
}
}
}
} else
scan = ((options)((int)(scan)+1));
} while (!(found || (scan == invalid)));
if (scan == invalid) {
(void)fprintf(output.fp, "RPCC: "), Putl(output, 0);
{
integer B38 = 1,
B39 = len;
if (B38 <= B39)
for (a = B38; ; a++) {
Putchr(arg->A[a - 1], output);
if (a == B39) break;
}
}
(void)fprintf(output.fp, ": unrecognized option, ignored.\n"), Putl(output, 1);
}
} else {
inp_name.len = len;
{
integer B40 = 1,
B41 = len;
if (B40 <= B41)
for (a = B40; ; a++) {
inp_name.str.A[a - 1] = arg->A[a - 1];
if (a == B41) break;
}
}
}
# undef magic1
# undef magic2
}
void
make_filename(filename, prefix)
astring *filename;
char3 prefix;
{
integer rdp;
register integer i;
boolean done;
rdp = inp_name.len;
done = false;
do {
if ((rdp >= 1)) {
if ((Member((unsigned)(inp_name.str.A[rdp - 1]), Conset[9])))
rdp = rdp - 1;
else
done = true;
} else
done = true;
} while (!(done));
filename->len = 0;
{
integer B42 = 1,
B43 = rdp;
if (B42 <= B43)
for (i = B42; ; i++) {
filename->len = filename->len + 1;
filename->str.A[filename->len - 1] = inp_name.str.A[i - 1];
if (i == B43) break;
}
}
{
integer B44 = 1,
B45 = 3;
if (B44 <= B45)
for (i = B44; ; i++) {
filename->len = filename->len + 1;
filename->str.A[filename->len - 1] = prefix.A[i - 1];
if (i == B45) break;
}
}
{
integer B46 = rdp + 1,
B47 = inp_name.len;
if (B46 <= B47)
for (i = B46; ; i++) {
filename->len = filename->len + 1;
filename->str.A[filename->len - 1] = inp_name.str.A[i - 1];
if (i == B47) break;
}
}
}
void
get_parameters()
{
typedef struct { char A[3 - 1 + 1]; } T83;
integer b, count, p_argc, p_len;
register integer a;
longstring p_argv;
T83 ext;
inp_name.len = 0;
if (commandline) {
count = 1;
get_argc(&p_argc);
while (count <= p_argc) {
get_argv(count, &p_argv, &p_len);
count = count + 1;
analize(&p_argv, p_len, false);
}
} else {
(void)fprintf(output.fp, "Input file name: "), Putl(output, 0);
{
register struct S103 *W48 = &inp_name;
W48->len = 0;
while (!(Eoln(input)) && (W48->len <= maxstring)) {
W48->len = W48->len + 1;
W48->str.A[W48->len - 1] = Getchr(input);
}
Getl(&input);
}
do {
(void)fprintf(output.fp, "Debugging options: "), Putl(output, 0);
count = 1;
while (!(Eoln(input)) && (count < maxstring)) {
count = count + 1;
p_argv.A[count - 1] = Getchr(input);
}
Getl(&input);
if (count > 1)
analize(&p_argv, count, true);
} while (!(count == 1));
}
if (inp_name.len == 0) {
(void)fprintf(output.fp, "RPCC: usage: source_file [options]\n"), Putl(output, 1);
abort_pgm(input_miss);
}
if (!(file_open(&inp_file, &inp_name, resetting)))
abort_pgm(cant_opn_input);
if (cli_name.len == 0)
make_filename(&cli_name, *((char3 *)STRALIGN("cli")));
if (ser_name.len == 0)
make_filename(&ser_name, *((char3 *)STRALIGN("ser")));
b = inp_name.len;
while ((b >= 1) && (Member((unsigned)(inp_name.str.A[b - 1]), Conset[10])))
b = b - 1;
if (b == 0)
b = inp_name.len;
if (inp_name.str.A[b - 1] != '.')
b = inp_name.len;
{
integer B49 = 1,
B50 = b;
if (B49 <= B50)
for (a = B49; ; a++) {
if (a <= maxstring - 3)
ext_name.str.A[a - 1] = inp_name.str.A[a - 1];
if (a == B50) break;
}
}
if ((b <= inp_name.len - 3)) {
ext.A[1 - 1] = inp_name.str.A[b + 1 - 1];
ext.A[2 - 1] = inp_name.str.A[b + 2 - 1];
ext.A[3 - 1] = inp_name.str.A[b + 3 - 1];
if ((Cmpstr(ext.A, "ext") == 0) || (Cmpstr(ext.A, "EXT") == 0))
abort_pgm(bad_input_name);
} else {
b = b + 1;
ext_name.str.A[b - 1] = '.';
}
ext_name.str.A[b + 1 - 1] = 'e';
ext_name.str.A[b + 2 - 1] = 'x';
ext_name.str.A[b + 3 - 1] = 't';
ext_name.len = b + 3;
}
void getoken();
char
ap_getchar()
{
# define tab 9
register char R87;
register integer a;
char localcar;
if (char_ready) {
R87 = oldchar;
char_ready = false;
} else {
{
register struct S104 *W51 = &inp_line;
while ((W51->start > W51->len) || (W51->len == 0)) {
W51->len = 0;
W51->start = 1;
lastindex = 1;
if (Eofx(inp_file))
abort_pgm(unexp_eof);
else {
while (!(Eoln(inp_file))) {
W51->len = W51->len + 1;
W51->str.A[W51->len - 1] = Getchr(inp_file);
if ((unsigned)(W51->str.A[W51->len - 1]) == tab)
W51->str.A[W51->len - 1] = ' ';
else
if ((unsigned)(W51->str.A[W51->len - 1]) < 32)
W51->len = W51->len - 1;
}
W51->len = W51->len + 1;
W51->str.A[W51->len - 1] = ' ';
Getl(&inp_file);
lineread = lineread + 1;
if (runoptions.A[(int)(dlex)].value) {
(void)fprintf(output.fp, "LINE READ: "), Putl(output, 0);
{
integer B52 = 1,
B53 = W51->len;
if (B52 <= B53)
for (a = B52; ; a++) {
Putchr(W51->str.A[a - 1], output);
if (a == B53) break;
}
}
Putchr('\n', output);
}
}
}
localcar = W51->str.A[W51->start - 1];
W51->start = W51->start + 1;
}
if (Member((unsigned)(localcar), Conset[11]))
localcar = (unsigned)('a') + (unsigned)(localcar) - (unsigned)('A');
R87 = localcar;
if ((localcar == '-') && !(incomment)) {
incomment = true;
oldchar = ap_getchar();
incomment = false;
if (oldchar == '-') {
inp_line.len = 0;
R87 = ' ';
} else {
R87 = localcar;
char_ready = true;
}
}
}
return R87;
# undef tab
}
char
C58_getchar()
{
register char R88;
char ch;
if (ch_there != ' ') {
ch = ch_there;
ch_there = ' ';
} else {
ch = ap_getchar();
if (ch == ' ') {
if (!Eofx(inp_file))
do {
ch = ap_getchar();
} while (!(ch != ' '));
if (!((Member((unsigned)(ch), Conset[12])) || is_blank)) {
ch_there = ch;
ch = ' ';
}
}
}
is_blank = (boolean)(Member((unsigned)(ch), Conset[13]));
checksum = (3 * checksum + (unsigned)(ch) - (unsigned)(' ')) % 8999;
if (runoptions.A[(int)(dlexhot)].value)
if (ch == ' ')
Putchr(ch, output),Putchr('\n', output);
else
Putchr(ch, output);
R88 = ch;
return R88;
}
void
getoken()
{
integer j, k, sign;
register integer i;
if (tok_present) {
token = lastoken;
tok_present = false;
} else {
{
register struct S105 *W54 = &token;
do {
if (lastcar == ' ')
lastcar = C58_getchar();
lastindex = inp_line.start;
if (Member((unsigned)(lastcar), Conset[14])) {
W54->kind = ident;
W54->U.V2.name.len = 0;
do {
if (W54->U.V2.name.len < maxidlen) {
W54->U.V2.name.len = W54->U.V2.name.len + 1;
W54->U.V2.name.str.A[W54->U.V2.name.len - 1] = lastcar;
}
lastcar = C58_getchar();
} while (!(!(Member((unsigned)(lastcar), Conset[15]))));
{
integer B55 = W54->U.V2.name.len + 1,
B56 = maxidlen;
if (B55 <= B56)
for (i = B55; ; i++) {
W54->U.V2.name.str.A[i - 1] = ' ';
if (i == B56) break;
}
}
i = 1;
j = maxkeyword;
do {
k = (i + j) / 2;
if (Cmpstr(W54->U.V2.name.str.A, keyword.A[k - 1].name.A) <= 0)
j = k - 1;
if (Cmpstr(W54->U.V2.name.str.A, keyword.A[k - 1].name.A) >= 0)
i = k + 1;
} while (!(i > j));
if (i - 1 > j) {
W54->kind = keyword.A[k - 1].symbol;
} else {
{
register struct S102 *W57 = &W54->U.V2.name;
if (((W57->str.A[1 - 1] == 'r') && (W57->str.A[2 - 1] == 'p') && (W57->str.A[3 - 1] == 'c') && (W57->str.A[4 - 1] == '_')) || (Cmpstr(W54->U.V2.name.str.A, "b ") == 0) || (Cmpstr(W54->U.V2.name.str.A, "header ") == 0) || (Cmpstr(W54->U.V2.name.str.A, "ret ") == 0))
linerror(ident_reserved);
}
W54->kind = ident;
}
} else
if (Member((unsigned)(lastcar), Conset[16])) {
W54->kind = number;
W54->U.V3.value = 0;
if (lastcar == '-') {
sign = -1;
lastcar = C58_getchar();
} else
sign = 1;
do {
if (W54->U.V3.value < (maxint / 10) - ((unsigned)(lastcar) - (unsigned)('0')))
W54->U.V3.value = W54->U.V3.value * 10 + (unsigned)(lastcar) - (unsigned)('0');
else {
error(toomany_dig);
W54->U.V3.value = maxint;
}
lastcar = C58_getchar();
} while (!(!(Member((unsigned)(lastcar), Conset[17]))));
W54->U.V3.value = W54->U.V3.value * sign;
} else {
if (!(Member((unsigned)(lastcar), Conset[18]))) {
W54->kind = nultok;
error(char_ignored);
} else {
switch ((int)(lastcar)) {
case ':':
W54->kind = colon;
break ;
case ';':
W54->kind = semicolon;
break ;
case ',':
W54->kind = comma;
break ;
case '(':
W54->kind = opnround;
break ;
case ')':
W54->kind = clsround;
break ;
case '.':
W54->kind = dot;
break ;
default:
Caseerror(Line);
}
}
lastcar = C58_getchar();
}
} while (!(W54->kind != nultok));
}
}
if (runoptions.A[(int)(dlex)].value)
print_token();
}
void
backtoken()
{
lastoken = token;
tok_present = true;
}
boolean
expected(what, skip_until)
type_token what;
set_of_token skip_until;
{
register boolean R89;
getoken();
if (token.kind == what)
R89 = true;
else {
R89 = false;
(void)fprintf(output.fp, "RPCC: Error: Found "), Putl(output, 0);
write_token(token.kind);
(void)fprintf(output.fp, " where "), Putl(output, 0);
write_token(what);
(void)fprintf(output.fp, " was expected on line %1d:\n", lineread), Putl(output, 1);
print_last_line();
Putchr('\n', output);
find_tok(skip_until);
}
return R89;
}
void
append_1(expr, ch)
expression *expr;
char ch;
{
{
register struct S106 *W58 = &(*expr);
W58->len = W58->len + 1;
W58->str.A[W58->len - 1] = ch;
}
}
void
format(final, template)
expression *final;
template_type template;
{
expression initial;
integer e;
register integer j;
register integer i;
initial = (*final);
final->len = 0;
e = template_length;
while (template.A[e - 1] == ' ')
e = e - 1;
{
integer B59 = 1,
B60 = e;
if (B59 <= B60)
for (i = B59; ; i++) {
if (template.A[i - 1] == '$')
{
integer B61 = 1,
B62 = initial.len;
if (B61 <= B62)
for (j = B61; ; j++) {
append_1(&(*final), initial.str.A[j - 1]);
if (j == B62) break;
}
}
else
append_1(&(*final), template.A[i - 1]);
if (i == B60) break;
}
}
}
void
prepend_1(expr, ch)
expression *expr;
char ch;
{
register integer a;
{
register struct S106 *W63 = &(*expr);
{
integer B64 = W63->len,
B65 = 1;
if (B64 >= B65)
for (a = B64; ; a--) {
W63->str.A[a + 1 - 1] = W63->str.A[a - 1];
if (a == B65) break;
}
}
W63->str.A[1 - 1] = ch;
W63->len = W63->len + 1;
}
}
void
append_name(expr, name)
expression *expr;
id_name name;
{
register integer a;
{
register struct S102 *W66 = &name;
{
integer B67 = 1,
B68 = W66->len;
if (B67 <= B68)
for (a = B67; ; a++) {
append_1(&(*expr), W66->str.A[a - 1]);
if (a == B68) break;
}
}
}
}
void
append_index(expr, level)
expression *expr;
integer level;
{
char ch;
format(&(*expr), *((template_type *)STRALIGN("$[rpc_ ")));
append_1(&(*expr), (unsigned)('a') + level - 1);
append_1(&(*expr), ']');
}
void
append_decimal(expr, x)
expression *expr;
integer x;
{
integer t, y, weight;
if (x < 0) {
append_1(&(*expr), '-');
t = -x;
} else
t = x;
weight = 1;
while (weight * 10 <= t)
weight = weight * 10;
while (weight > 0) {
append_1(&(*expr), (unsigned)('0') + t / weight);
t = t % weight;
weight = weight / 10;
}
}
boolean
find_type(head, name, father, son)
ptr_named_type head;
id_name *name;
ptr_named_type *father;
ptr_named_type *son;
{
register boolean R90;
boolean found, doexit;
found = false;
(*son) = head;
(*father) = (*son);
while (((*son) != (struct S76 *)NIL) && !(found)) {
if (Cmpstr((*son)->nty_name.str.A, name->str.A) == 0)
found = true;
else {
(*father) = (*son);
(*son) = (*son)->nty_next;
}
}
R90 = found;
return R90;
}
void
insert_named_type(ptr, head)
ptr_named_type ptr;
ptr_named_type *head;
{
ptr_named_type son, father;
if (find_type((*head), &ptr->nty_name, &father, &son)) {
linerror(twice_declared);
} else {
if ((*head) == (struct S76 *)NIL) {
(*head) = ptr;
ptr->nty_next = (struct S76 *)NIL;
} else
if ((*head) == son) {
(*head) = ptr;
ptr->nty_next = son;
} else {
father->nty_next = ptr;
ptr->nty_next = son;
}
}
}
boolean
find_block(name, father, son)
id_name *name;
ptr_block_table *father;
ptr_block_table *son;
{
register boolean R91;
boolean found;
found = false;
(*son) = blockptr;
(*father) = (*son);
while (((*son) != (struct S78 *)NIL) && !(found)) {
if (Cmpstr((*son)->name.str.A, name->str.A) == 0)
found = true;
else {
(*father) = (*son);
(*son) = (*son)->next;
}
}
R91 = found;
return R91;
}
boolean
find_param(name, head, son)
id_name *name;
ptr_idlist head;
ptr_idlist *son;
{
register boolean R92;
boolean found;
(*son) = head;
found = false;
while (((*son) != (struct S77 *)NIL) && !found) {
if (Cmpstr((*son)->name.str.A, name->str.A) == 0)
found = true;
else
(*son) = (*son)->next;
}
R92 = found;
return R92;
}
void
ensure_type_named(pt)
ptr_defined_type pt;
{
register integer i;
expression expr;
ptr_named_type pnt;
if (pt != (struct S75 *)NIL)
{
register struct S75 *W69 = &(*pt);
if (W69->typ_name == (struct S76 *)NIL) {
pnt = (struct S76 *)malloc((unsigned)(sizeof(*pnt)));
{
register struct S76 *W70 = &(*pnt);
format(&expr, *((template_type *)STRALIGN("rpc_stype_")));
append_decimal(&expr, number_of_invented_types);
number_of_invented_types = number_of_invented_types + 1;
{
integer B71 = 1,
B72 = expr.len;
if (B71 <= B72)
for (i = B71; ; i++) {
W70->nty_name.str.A[i - 1] = expr.str.A[i - 1];
if (i == B72) break;
}
}
W70->nty_name.len = expr.len;
W70->nty_type = pt;
W69->typ_name = pnt;
insert_named_type(pnt, &typeptr);
}
}
}
}
ptr_defined_type parse_type();
void
get_size(pt)
ptr_defined_type pt;
{
{
register struct S75 *W73 = &(*pt);
getoken();
if (token.kind != opnround)
linerror(opnround_miss);
else
getoken();
W73->U.V4.typ_low = 1;
if (token.kind != number) {
linerror(number_req);
W73->U.V4.typ_high = 0;
} else {
W73->U.V4.typ_high = token.U.V3.value;
getoken();
}
if (token.kind != clsround) {
errfind(clsround_miss, *((set_of_token *)SETALIGN(Conset[19])));
backtoken();
}
if (W73->U.V4.typ_high < 0)
linerror(positive_req);
}
}
ptr_defined_type
parse_subarray()
{
register ptr_defined_type R94;
ptr_defined_type pt;
pt = (struct S75 *)malloc((unsigned)(sizeof(*pt)));
{
register struct S75 *W74 = &(*pt);
W74->typ_name = (struct S76 *)NIL;
W74->typ_external = false;
W74->typ_subtype = (struct S75 *)NIL;
W74->typ_basic_type = arraytok;
getoken();
if (token.kind != number) {
linerror(number_req);
W74->U.V4.typ_low = 0;
} else {
W74->U.V4.typ_low = token.U.V3.value;
getoken();
}
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);
W74->U.V4.typ_high = W74->U.V4.typ_low + 1;
} else {
W74->U.V4.typ_high = token.U.V3.value;
getoken();
}
if (W74->U.V4.typ_high <= W74->U.V4.typ_low)
linerror(invalid_range);
if (token.kind == comma) {
W74->typ_subtype = parse_subarray();
} else
if (token.kind == clsround) {
getoken();
if (token.kind == oftok) {
getoken();
W74->typ_subtype = parse_type();
} else {
errfind(clsround_miss, *((set_of_token *)SETALIGN(Conset[20])));
backtoken();
}
} else {
errfind(clsround_miss, *((set_of_token *)SETALIGN(Conset[21])));
backtoken();
}
if (W74->typ_subtype == (struct S75 *)NIL) {
free(pt);
R94 = (struct S75 *)NIL;
} else {
W74->typ_min_size = (W74->U.V4.typ_high - W74->U.V4.typ_low + 1) * W74->typ_subtype->typ_min_size;
W74->typ_max_size = (W74->U.V4.typ_high - W74->U.V4.typ_low + 1) * W74->typ_subtype->typ_max_size;
W74->typ_nesting = W74->typ_subtype->typ_nesting + 1;
R94 = pt;
}
}
return R94;
}
ptr_defined_type
parse_type()
{
register ptr_defined_type R93;
ptr_defined_type pt;
ptr_named_type pnt;
boolean loc_err;
ptr_named_type father, son;
if (token.kind == ident) {
if (find_type(typeptr, &token.U.V2.name, &father, &son))
R93 = son->nty_type;
else
linerror(id_not_declared);
} else
if (Member((unsigned)(token.kind), Conset[22])) {
R93 = simple_descriptor.A[(int)(token.kind)];
} else
if (token.kind == arraytok) {
getoken();
if (token.kind != opnround) {
linerror(opnround_miss);
backtoken();
R93 = (struct S75 *)NIL;
} else
R93 = parse_subarray();
} else
if (token.kind == accesstok) {
pt = (struct S75 *)malloc((unsigned)(sizeof(*pt)));
{
register struct S75 *W75 = &(*pt);
W75->typ_basic_type = token.kind;
W75->typ_external = false;
getoken();
W75->typ_subtype = parse_type();
ensure_type_named(W75->typ_subtype);
if (W75->typ_subtype != (struct S75 *)NIL) {
W75->typ_nesting = W75->typ_subtype->typ_nesting;
W75->typ_min_size = 4;
W75->typ_max_size = W75->typ_subtype->typ_max_size + 4;
}
}
R93 = pt;
} else
if (token.kind == recordtok) {
pt = (struct S75 *)malloc((unsigned)(sizeof(*pt)));
R93 = pt;
{
register struct S75 *W76 = &(*pt);
W76->typ_basic_type = token.kind;
W76->typ_external = false;
W76->typ_subtype = (struct S75 *)NIL;
W76->U.V5.typ_fields = (struct S76 *)NIL;
W76->typ_nesting = 0;
W76->typ_min_size = 0;
W76->typ_max_size = 0;
getoken();
while (token.kind == ident) {
pnt = (struct S76 *)malloc((unsigned)(sizeof(*pnt)));
pnt->nty_name = token.U.V2.name;
getoken();
if (token.kind != colon)
linerror(colon_miss);
else
getoken();
pnt->nty_type = parse_type();
if (pnt->nty_type != (struct S75 *)NIL) {
if (pnt->nty_type->typ_nesting > W76->typ_nesting)
W76->typ_nesting = pnt->nty_type->typ_nesting;
W76->typ_min_size = W76->typ_min_size + pnt->nty_type->typ_min_size;
W76->typ_max_size = W76->typ_max_size + pnt->nty_type->typ_max_size;
insert_named_type(pnt, &W76->U.V5.typ_fields);
ensure_type_named(pnt->nty_type);
}
getoken();
if (token.kind != semicolon) {
errfind(semicol_miss, *((set_of_token *)SETALIGN(Conset[23])));
if (token.kind == semicolon)
getoken();
} else
getoken();
}
}
if (token.kind != endtok)
errfind(endtok_miss, *((set_of_token *)SETALIGN(Conset[24])));
getoken();
if (token.kind != recordtok) {
linerror(record_miss);
if (token.kind == semicolon)
backtoken();
}
} else
if (token.kind == sequence) {
pt = (struct S75 *)malloc((unsigned)(sizeof(*pt)));
pt->typ_basic_type = token.kind;
R93 = pt;
get_size(pt);
getoken();
if (token.kind != oftok)
linerror(oftok_miss);
else
{
register struct S75 *W77 = &(*pt);
getoken();
W77->typ_external = false;
W77->typ_subtype = parse_type();
W77->typ_nesting = W77->typ_subtype->typ_nesting + 1;
W77->typ_min_size = 2;
W77->typ_max_size = (W77->typ_subtype->typ_max_size * (W77->U.V4.typ_high - W77->U.V4.typ_low + 1)) + 2;
}
} else
if (Member((unsigned)(token.kind), Conset[25])) {
pt = (struct S75 *)malloc((unsigned)(sizeof(*pt)));
R93 = pt;
{
register struct S75 *W78 = &(*pt);
W78->typ_basic_type = token.kind;
get_size(pt);
W78->typ_subtype = simple_descriptor.A[(int)(chartok)];
W78->typ_external = false;
if (W78->typ_basic_type == stringtok) {
W78->typ_nesting = 2;
W78->typ_max_size = W78->U.V4.typ_high + 2;
W78->typ_min_size = 2;
} else {
W78->typ_nesting = 1;
W78->typ_max_size = W78->U.V4.typ_high + 4;
W78->typ_min_size = 4;
}
}
} else {
linerror(ill_basic_type);
loc_err = true;
backtoken();
R93 = (struct S75 *)NIL;
}
return R93;
}
void
parse_pragma()
{
id_name pragma_name;
ptr_block_table blk, block_father;
ptr_named_type nty, type_father;
register integer i;
ptr_defined_type typ;
ptr_idlist param;
if (expected(ident, *((set_of_token *)SETALIGN(Conset[26])))) {
pragma_name = token.U.V2.name;
if (expected(opnround, *((set_of_token *)SETALIGN(Conset[27]))))
if (expected(ident, *((set_of_token *)SETALIGN(Conset[28]))))
if (Cmpstr(pragma_name.str.A, "timeout ") == 0) {
if (find_block(&token.U.V2.name, &block_father, &blk))
if (expected(comma, *((set_of_token *)SETALIGN(Conset[29]))))
if (expected(number, *((set_of_token *)SETALIGN(Conset[30])))) {
blk->blk_timeout = token.U.V3.value;
if (expected(clsround, *((set_of_token *)SETALIGN(Conset[31]))))
if (expected(semicolon, *((set_of_token *)SETALIGN(Conset[32]))))
;
}
} else
if ((Cmpstr(pragma_name.str.A, "concurrent ") == 0) || (Cmpstr(pragma_name.str.A, "cast ") == 0)) {
while (token.kind == ident) {
if (find_block(&token.U.V2.name, &block_father, &blk)) {
if (pragma_name.str.A[2 - 1] == 'o')
blk->blk_concurrent = true;
else
blk->blk_cast = true;
} else {
(void)fprintf(output.fp, "RPCC: PRAGMA CAST or CONCURRENT must refer to previously defined procedure\n"), Putl(output, 1);
linerror(id_not_declared);
}
getoken();
if (token.kind == comma)
if (expected(ident, *((set_of_token *)SETALIGN(Conset[33]))))
;
}
if (token.kind == clsround) {
if (expected(semicolon, *((set_of_token *)SETALIGN(Conset[34]))))
;
} else {
linerror(clsround_miss);
if (token.kind != semicolon)
if (expected(semicolon, *((set_of_token *)SETALIGN(Conset[35]))))
;
}
} else
if (Cmpstr(pragma_name.str.A, "external_marshalling ") == 0) {
if (find_type(typeptr, &token.U.V2.name, &type_father, &nty)) {
if (nty->nty_type->typ_name != nty) {
typ = (struct S75 *)malloc((unsigned)(sizeof(*typ)));
(*typ) = (*nty->nty_type);
typ->typ_name = nty;
nty->nty_type = typ;
}
nty->nty_type->typ_external = true;
nty->nty_type->typ_nesting = 0;
external_marshalling = true;
} else {
(void)fprintf(output.fp, "RPCC: PRAGMA EXTERNAL_MARSHALLING must refer to previously defined type\n"), Putl(output, 1);
linerror(id_not_declared);
}
if (expected(clsround, *((set_of_token *)SETALIGN(Conset[36]))))
if (expected(semicolon, *((set_of_token *)SETALIGN(Conset[37]))))
;
} else
if (Cmpstr(pragma_name.str.A, "call_status ") == 0) {
if (!find_block(&token.U.V2.name, &block_father, &blk)) {
(void)fprintf(output.fp, "RPCC: PRAGMA CALL_STATUS: First arg (proc/func name) not (yet) declared\n"), Putl(output, 1);
linerror(id_not_declared);
} else
if (expected(comma, *((set_of_token *)SETALIGN(Conset[38]))))
if (expected(ident, *((set_of_token *)SETALIGN(Conset[39]))))
if (!find_param(&token.U.V2.name, blk->list, ¶m)) {
(void)fprintf(output.fp, " RPCC: PRAGMA CALL_STATUS:\n"), Putl(output, 1);
(void)fprintf(output.fp, " Second argument must be formal param. of proc/func\n"), Putl(output, 1);
linerror(id_not_declared);
} else {
if (blk->blk_status_param != (struct S77 *)NIL) {
(void)fprintf(output.fp, "RPCC: Proc/func already has a CALL_STATUS parameter\n"), Putl(output, 1);
linerror(twice_declared);
} else
blk->blk_status_param = param;
}
if (expected(clsround, *((set_of_token *)SETALIGN(Conset[40]))))
if (expected(semicolon, *((set_of_token *)SETALIGN(Conset[41]))))
;
} else {
(void)fprintf(output.fp, "RPCC: Ignoring unknown pragma \""), Putl(output, 0);
{
register struct S102 *W79 = &pragma_name;
{
integer B80 = 1,
B81 = W79->len;
if (B80 <= B81)
for (i = B80; ; i++) {
Putchr(W79->str.A[i - 1], output);
if (i == B81) break;
}
}
}
Putchr('"', output),Putchr('\n', output);
find_tok(*((set_of_token *)SETALIGN(Conset[42])));
}
}
getoken();
}
void
type_declare()
{
named_type elem;
ptr_named_type pnt;
while (!(Member((unsigned)(token.kind), Conset[43]))) {
if (token.kind == pragmatok)
parse_pragma();
else
if (token.kind != typetok) {
errfind(type_miss, *((set_of_token *)SETALIGN(Conset[44])));
} else {
getoken();
if (token.kind != ident) {
errfind(ident_req, *((set_of_token *)SETALIGN(Conset[45])));
} else {
pnt = (struct S76 *)malloc((unsigned)(sizeof(*pnt)));
pnt->nty_name = token.U.V2.name;
getoken();
if (token.kind != istok)
linerror(istok_miss);
else
getoken();
pnt->nty_type = parse_type();
if (pnt->nty_type != (struct S75 *)NIL) {
insert_named_type(pnt, &typeptr);
if (pnt->nty_type->typ_name == (struct S76 *)NIL)
pnt->nty_type->typ_name = pnt;
}
getoken();
if (token.kind != semicolon) {
errfind(semicol_miss, *((set_of_token *)SETALIGN(Conset[46])));
if (token.kind == semicolon)
getoken();
} else
getoken();
}
}
}
}
void parse_parameter_list();
ptr_idlist
fnd_idlist(name, last, head)
id_name *name;
ptr_idlist *last;
ptr_idlist head;
{
register ptr_idlist R95;
ptr_idlist scan;
boolean found;
scan = head;
(*last) = head;
found = false;
while ((scan != (struct S77 *)NIL) && !(found))
if (Cmpstr(scan->name.str.A, name->str.A) == 0)
found = true;
else {
(*last) = scan;
scan = scan->next;
}
R95 = scan;
return R95;
}
ptr_idlist
get_idlist()
{
register ptr_idlist R96;
ptr_idlist localist, last, scan;
ptr_named_type junk1, junk2;
localist = (struct S77 *)NIL;
do {
getoken();
if (token.kind != ident)
errfind(ident_req, *((set_of_token *)SETALIGN(Conset[47])));
if (token.kind == ident) {
if (find_type(typeptr, &token.U.V2.name, &junk1, &junk2) || (fnd_idlist(&token.U.V2.name, &scan, (*G107_headlist)) != (struct S77 *)NIL) || (fnd_idlist(&token.U.V2.name, &last, localist) != (struct S77 *)NIL))
linerror(twice_declared);
else {
scan = (struct S77 *)malloc((unsigned)(sizeof(*scan)));
scan->name = token.U.V2.name;
scan->next = (struct S77 *)NIL;
if (last == (struct S77 *)NIL)
localist = scan;
else
last->next = scan;
}
getoken();
}
} while (!(token.kind != comma));
R96 = localist;
return R96;
}
void
parse_parameter_list(block)
block_table *block;
{
ptr_idlist identlist, headlist, tailist, last;
ptr_named_type scan2type, junk;
ptr_defined_type ptr2type;
attr_type direction;
boolean got_error;
ptr_idlist *F108;
F108 = G107_headlist;
G107_headlist = &headlist;
got_error = false;
(*G107_headlist) = (struct S77 *)NIL;
do {
identlist = get_idlist();
if (token.kind != colon)
linerror(colon_miss);
else
getoken();
if (!(Member((unsigned)(token.kind), Conset[48]))) {
direction = intok;
} else {
direction = token.kind;
getoken();
if ((direction == intok) && (token.kind == outok)) {
direction = inoutok;
getoken();
}
}
ptr2type = parse_type();
ensure_type_named(ptr2type);
if ((identlist != (struct S77 *)NIL) && (ptr2type != (struct S75 *)NIL))
{
register struct S78 *W82 = &(*block);
if (ptr2type->typ_nesting > W82->blk_nesting)
W82->blk_nesting = ptr2type->typ_nesting;
if ((*G107_headlist) == (struct S77 *)NIL)
(*G107_headlist) = identlist;
else
tailist->next = identlist;
tailist = identlist;
do {
tailist->attr = direction;
tailist->id_type = ptr2type;
last = tailist;
tailist = tailist->next;
if (Member((unsigned)(direction), Conset[49])) {
W82->blk_max_in = W82->blk_max_in + ptr2type->typ_max_size;
W82->blk_min_in = W82->blk_min_in + ptr2type->typ_min_size;
}
if (Member((unsigned)(direction), Conset[50])) {
W82->blk_max_out = W82->blk_max_out + ptr2type->typ_max_size;
W82->blk_min_out = W82->blk_min_out + ptr2type->typ_min_size;
}
} while (!(tailist == (struct S77 *)NIL));
tailist = last;
}
getoken();
if (!(Member((unsigned)(token.kind), Conset[51]))) {
errfind(semic_round_miss, *((set_of_token *)SETALIGN(Conset[52])));
switch ((int)(token.kind)) {
case semicolon: case clsround:
break ;
case ident:
backtoken();
break ;
case colon: case functok: case proctok:
got_error = true;
backtoken();
break ;
default:
Caseerror(Line);
}
}
} while (!((token.kind == clsround) || (got_error)));
block->list = (*G107_headlist);
G107_headlist = F108;
}
void
block_declare()
{
block_table block;
ptr_named_type junk1, scan;
ptr_block_table blk, junk2, lastblock;
boolean localerr;
ptr_idlist ascan;
do {
localerr = false;
{
register struct S78 *W83 = █
W83->blk_nesting = 0;
W83->blk_min_in = 0;
W83->blk_min_out = 0;
W83->blk_max_in = 0;
W83->blk_max_out = 0;
}
if (!(Member((unsigned)(token.kind), Conset[53])))
errfind(proc_exp, *((set_of_token *)SETALIGN(Conset[54])));
if (token.kind == pragmatok)
parse_pragma();
else
if (token.kind != endtok) {
block.b_type = token.kind;
block.in_only = (boolean)(token.kind == proctok);
getoken();
if (token.kind != ident) {
linerror(ident_req);
localerr = true;
} else {
block.name = token.U.V2.name;
if (find_type(typeptr, &token.U.V2.name, &junk1, &scan) || find_block(&token.U.V2.name, &lastblock, &junk2)) {
linerror(twice_declared);
localerr = true;
}
}
getoken();
if (token.kind == opnround) {
parse_parameter_list(&block);
getoken();
} else
if (Member((unsigned)(token.kind), Conset[55])) {
linerror(opnround_miss);
backtoken();
parse_parameter_list(&block);
getoken();
} else
block.list = (struct S77 *)NIL;
if (block.b_type == functok) {
if (token.kind != E1_C33_return)
linerror(return_miss);
else
getoken();
if (token.kind == ident) {
if (find_type(typeptr, &token.U.V2.name, &junk1, &scan))
block.C33_return = scan->nty_type->typ_basic_type;
else {
linerror(id_not_declared);
localerr = true;
}
} else
block.C33_return = token.kind;
if (Member((unsigned)(block.C33_return), Conset[56])) {
getoken();
block.blk_max_out = block.blk_max_out + simple_descriptor.A[(int)(block.C33_return)]->typ_max_size;
block.blk_min_out = block.blk_min_out + simple_descriptor.A[(int)(block.C33_return)]->typ_min_size;
} else {
localerr = true;
linerror(simtype_req);
}
} else {
ascan = block.list;
while (ascan != (struct S77 *)NIL) {
if (ascan->attr != intok)
block.in_only = false;
ascan = ascan->next;
}
}
if (token.kind != semicolon) {
errfind(semicol_miss, *((set_of_token *)SETALIGN(Conset[57])));
if (token.kind == semicolon)
getoken();
} else
getoken();
if (!localerr) {
blk = (struct S78 *)malloc((unsigned)(sizeof(*blk)));
(*blk) = block;
blk->next = (struct S78 *)NIL;
blk->blk_status_param = (struct S77 *)NIL;
blk->blk_cast = false;
blk->blk_concurrent = false;
if (runoptions.A[(int)(timeout)].value)
blk->blk_timeout = timeout_val;
else
blk->blk_timeout = rpc_default_timeout;
if (lastblock == (struct S78 *)NIL)
blockptr = blk;
else
lastblock->next = blk;
}
}
} while (!(token.kind == endtok));
}
void
initialise_parser()
{
register type_token t;
{
type_token B84 = chartok,
B85 = longtok;
if ((int)(B84) <= (int)(B85))
for (t = B84; ; t = (type_token)((int)(t)+1)) {
simple_descriptor.A[(int)(t)] = (struct S75 *)malloc((unsigned)(sizeof(*simple_descriptor.A[(int)(t)])));
{
register struct S75 *W86 = &(*simple_descriptor.A[(int)(t)]);
W86->typ_basic_type = t;
W86->typ_nesting = 0;
W86->typ_subtype = (struct S75 *)NIL;
W86->typ_name = (struct S76 *)malloc((unsigned)(sizeof(*W86->typ_name)));
{
register struct S76 *W87 = &(*W86->typ_name);
W87->nty_name.len = maxidlen;
W87->nty_type = simple_descriptor.A[(int)(t)];
W87->nty_next = (struct S76 *)NIL;
}
switch ((int)(t)) {
case chartok: case bytetok:
W86->typ_max_size = 1;
break ;
case shortok: case integertok:
W86->typ_max_size = 2;
break ;
case real32tok: case longtok:
W86->typ_max_size = 4;
break ;
case real48tok: case real64tok:
W86->typ_max_size = 8;
break ;
case real128tok:
W86->typ_max_size = 16;
break ;
default:
Caseerror(Line);
}
W86->typ_min_size = W86->typ_max_size;
}
if (t == B85) break;
}
}
(void)strncpy(simple_descriptor.A[(int)(chartok)]->typ_name->nty_name.str.A, "rpc_char ", sizeof(simple_descriptor.A[(int)(chartok)]->typ_name->nty_name.str.A));
(void)strncpy(simple_descriptor.A[(int)(bytetok)]->typ_name->nty_name.str.A, "rpc_byte ", sizeof(simple_descriptor.A[(int)(bytetok)]->typ_name->nty_name.str.A));
(void)strncpy(simple_descriptor.A[(int)(shortok)]->typ_name->nty_name.str.A, "rpc_short ", sizeof(simple_descriptor.A[(int)(shortok)]->typ_name->nty_name.str.A));
(void)strncpy(simple_descriptor.A[(int)(integertok)]->typ_name->nty_name.str.A, "rpc_integer ", sizeof(simple_descriptor.A[(int)(integertok)]->typ_name->nty_name.str.A));
(void)strncpy(simple_descriptor.A[(int)(real32tok)]->typ_name->nty_name.str.A, "rpc_real32 ", sizeof(simple_descriptor.A[(int)(real32tok)]->typ_name->nty_name.str.A));
(void)strncpy(simple_descriptor.A[(int)(longtok)]->typ_name->nty_name.str.A, "rpc_long ", sizeof(simple_descriptor.A[(int)(longtok)]->typ_name->nty_name.str.A));
(void)strncpy(simple_descriptor.A[(int)(real48tok)]->typ_name->nty_name.str.A, "rpc_real48 ", sizeof(simple_descriptor.A[(int)(real48tok)]->typ_name->nty_name.str.A));
(void)strncpy(simple_descriptor.A[(int)(real64tok)]->typ_name->nty_name.str.A, "rpc_real64 ", sizeof(simple_descriptor.A[(int)(real64tok)]->typ_name->nty_name.str.A));
(void)strncpy(simple_descriptor.A[(int)(real128tok)]->typ_name->nty_name.str.A, "rpc_real128 ", sizeof(simple_descriptor.A[(int)(real128tok)]->typ_name->nty_name.str.A));
{
type_token B88 = chartok,
B89 = longtok;
if ((int)(B88) <= (int)(B89))
for (t = B88; ; t = (type_token)((int)(t)+1)) {
{
register struct S75 *W90 = &(*simple_descriptor.A[(int)(t)]);
register struct S76 *W91 = &(*W90->typ_name);
register struct S102 *W92 = &W91->nty_name;
while (W92->str.A[W92->len - 1] == ' ')
W92->len = W92->len - 1;
}
if (t == B89) break;
}
}
number_of_invented_types = 0;
external_marshalling = false;
}
void
parser()
{
initialise_parser();
getoken();
if (token.kind != package)
linerror(package_miss);
else
getoken();
if (token.kind != ident)
linerror(ident_req);
else {
unitname = token.U.V2.name;
getoken();
}
if (token.kind != istok)
linerror(istok_miss);
else
getoken();
type_declare();
if (token.kind == endtok)
linerror(blocks_req);
else {
block_declare();
if (token.kind != endtok)
linerror(endtok_miss);
else
getoken();
if (token.kind != ident)
linerror(ident_req);
else
if (Cmpstr(token.U.V2.name.str.A, unitname.str.A) != 0)
linerror(bad_name);
getoken();
if (token.kind != semicolon)
linerror(semicol_miss);
}
}
char
upper_case(ch)
char ch;
{
register char R97;
if ((ch >= 'a') && (ch <= 'z'))
R97 = (unsigned)(ch) - (unsigned)('a') + (unsigned)('A');
else
R97 = ch;
return R97;
}
void
write_name(where, name)
text *where;
id_name *name;
{
register integer a;
{
register struct S102 *W93 = &(*name);
{
integer B94 = 1,
B95 = W93->len;
if (B94 <= B95)
for (a = B94; ; a++) {
if (omode == vaxfor)
Putchr(upper_case(W93->str.A[a - 1]), (*where));
else
Putchr(W93->str.A[a - 1], (*where));
if (a == B95) break;
}
}
}
}
void
write_exp(where, expr)
text *where;
expression *expr;
{
register integer a;
{
register struct S106 *W96 = &(*expr);
{
integer B97 = 1,
B98 = W96->len;
if (B97 <= B98)
for (a = B97; ; a++) {
if (omode == vaxfor)
Putchr(upper_case(W96->str.A[a - 1]), (*where));
else
Putchr(W96->str.A[a - 1], (*where));
if (a == B98) break;
}
}
}
}
void
write_name_padded(op_file, name, ch)
text *op_file;
id_name name;
char ch;
{
Putchr(ch, (*op_file));
write_name(&(*op_file), &name);
(void)fprintf((*op_file).fp, "%*c", rpc_name_length + 1 - name.len, ch), Putl((*op_file), 0);
}
void
codefor_error(why)
error_string why;
{
(void)fprintf(output.fp, " RPCC: **** Error: %.48s\n", why.A), Putl(output, 1);
(void)fprintf(output.fp, " (Error detected at FORTRAN code generator stage.)\n"), Putl(output, 1);
abort();
}
integer
indfor(level)
integer level;
{
register integer R98;
R98 = 3 + level * 3;
return R98;
}
void
continuation()
{
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " +"), Putl(op_file, 0);
}
void
append_index_for(expr, level)
expression *expr;
integer level;
{
char ch;
format(&(*expr), *((template_type *)STRALIGN("$(RPC_ ")));
append_1(&(*expr), (unsigned)('A') + level - 1);
append_1(&(*expr), ')');
}
void
pack_simple_for(where, what, topack)
text *where;
type_token what;
boolean topack;
{
(void)fprintf((*where).fp, " CALL "), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "PCK_"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "UPK_"), Putl((*where), 0);
switch ((int)(what)) {
case chartok:
(void)fprintf((*where).fp, "CHAR"), Putl((*where), 0);
break ;
case bytetok:
(void)fprintf((*where).fp, "BYTE"), Putl((*where), 0);
break ;
case shortok:
(void)fprintf((*where).fp, "SHORT"), Putl((*where), 0);
break ;
case integertok:
(void)fprintf((*where).fp, "INTEGER"), Putl((*where), 0);
break ;
case real32tok:
(void)fprintf((*where).fp, "REAL32"), Putl((*where), 0);
break ;
case real48tok:
(void)fprintf((*where).fp, "REAL48"), Putl((*where), 0);
break ;
case real64tok:
(void)fprintf((*where).fp, "REAL64"), Putl((*where), 0);
break ;
case real128tok:
(void)fprintf((*where).fp, "REAL128"), Putl((*where), 0);
break ;
case longtok:
(void)fprintf((*where).fp, "LONG"), Putl((*where), 0);
break ;
default:
Caseerror(Line);
}
(void)fprintf((*where).fp, "_FOR(RPC_P_BUF,"), Putl((*where), 0);
}
void
gen_align_for(power, level)
integer power;
integer level;
{
(void)fprintf(op_file.fp, "%*cCALL RPC_ALIGN(RPC_P_BUF,%1d)\n", indfor(level), ' ', power), Putl(op_file, 1);
}
void
gen_pack_type_for(where, expr, typ, level, topack)
text *where;
expression expr;
ptr_defined_type typ;
integer level;
boolean topack;
{
char ch;
ptr_named_type scan;
ptr_defined_type element;
integer depth;
expression exp2;
expression l_expr, s_expr;
register integer i;
integer local_label;
ch = (unsigned)('A') + level - 1;
l_expr = expr;
prepend_1(&l_expr, '_');
s_expr = l_expr;
prepend_1(&l_expr, 'L');
prepend_1(&s_expr, 'S');
{
register struct S75 *W99 = &(*typ);
if (W99->typ_external) {
(void)fprintf((*where).fp, "%*cCALL ", indfor(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "PCK_"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "UPK_"), Putl((*where), 0);
write_name(&op_file, &W99->typ_name->nty_name);
(void)fprintf((*where).fp, "_FOR(RPC_P_BUF,"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(')', (*where)),Putchr('\n', (*where));
} else
switch ((int)(W99->typ_basic_type)) {
case chartok:
(void)fprintf((*where).fp, "%*cCALL ", indfor(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "PCK"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "UPK"), Putl((*where), 0);
(void)fprintf((*where).fp, "_CHAR_FOR(RPC_P_BUF,"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(')', (*where)),Putchr('\n', (*where));
break ;
case bytetok: case shortok: case integertok: case real32tok:
case real48tok: case real64tok: case real128tok: case longtok:
(void)fprintf((*where).fp, "%*cCALL ", indfor(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "PCK"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "UPK"), Putl((*where), 0);
{
register struct S102 *W100 = &W99->typ_name->nty_name;
{
integer B101 = 4,
B102 = W100->len;
if (B101 <= B102)
for (i = B101; ; i++) {
Putchr(upper_case(W100->str.A[i - 1]), (*where));
if (i == B102) break;
}
}
}
(void)fprintf((*where).fp, "_FOR(RPC_P_BUF,"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(')', (*where)),Putchr('\n', (*where));
break ;
case arraytok:
exp2 = expr;
depth = level;
ch = (unsigned)('A') + depth - 1;
element = W99->typ_subtype;
format(&exp2, *((template_type *)STRALIGN("$(RPC_ ")));
append_1(&exp2, ch);
(void)fprintf((*where).fp, "%*cDO %1d, RPC_%c=1,%1d\n", indfor(depth), ' ', next_label, ch, W99->U.V4.typ_high - W99->U.V4.typ_low + 1), Putl((*where), 1);
next_label = next_label + 1;
while (element->typ_basic_type == arraytok)
{
register struct S75 *W103 = &(*element);
depth = depth + 1;
ch = (unsigned)('A') + depth - 1;
(void)fprintf((*where).fp, "%*cDO %1d, RPC_%c=1,%1d\n", indfor(depth), ' ', next_label, ch, W103->U.V4.typ_high - W103->U.V4.typ_low + 1), Putl((*where), 1);
next_label = next_label + 1;
format(&exp2, *((template_type *)STRALIGN("$,RPC_ ")));
append_1(&exp2, ch);
element = element->typ_subtype;
}
append_1(&exp2, ')');
local_label = next_label;
gen_pack_type_for(&(*where), exp2, element, depth + 1, topack);
while (depth >= level) {
local_label = local_label - 1;
(void)fprintf((*where).fp, "%4d%*cCONTINUE\n", local_label, indfor(depth) - 4, ' '), Putl((*where), 1);
depth = depth - 1;
}
break ;
case recordtok:
scan = W99->U.V5.typ_fields;
while (scan != (struct S76 *)NIL)
{
register struct S76 *W104 = &(*scan);
exp2 = expr;
append_1(&exp2, '.');
append_name(&exp2, W104->nty_name);
gen_pack_type_for(&(*where), exp2, W104->nty_type, level, topack);
scan = W104->nty_next;
}
break ;
case accesstok:
codefor_error(*((error_string *)STRALIGN("No ACCESS (POINTER) type exists in FORTRAN! ")));
break ;
case sequence:
if (level > 1)
codefor_error(*((error_string *)STRALIGN("SEQUENCE type not allowed within composite type.")));
gen_pack_type_for(&(*where), l_expr, simple_descriptor.A[(int)(integertok)], level, topack);
exp2 = expr;
format(&exp2, *((template_type *)STRALIGN("A_$ ")));
append_index_for(&exp2, level);
(void)fprintf((*where).fp, "%*c", indfor(level), ' '), Putl((*where), 0);
(void)fprintf((*where).fp, "DO %1d, RPC_%c=1, L_", next_label, ch), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr('\n', (*where));
local_label = next_label;
next_label = next_label + 1;
gen_pack_type_for(&(*where), exp2, W99->typ_subtype, level + 1, topack);
(void)fprintf((*where).fp, "%4d%*cCONTINUE\n", local_label, indfor(level) - 4, ' '), Putl((*where), 1);
break ;
case stringtok:
(void)fprintf((*where).fp, "%*c", indfor(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "CALL PCK_STRING_FOR"), Putl((*where), 0);
else
if (client)
(void)fprintf((*where).fp, "CALL UPK_STRING_FOR"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "CALL UPK_VSTRING_FOR"), Putl((*where), 0);
(void)fprintf((*where).fp, "(RPC_P_BUF,"), Putl((*where), 0);
write_exp(&(*where), &expr);
if (!topack && !client)
(void)fprintf((*where).fp, ",%1d", W99->U.V4.typ_high), Putl((*where), 0);
Putchr(')', (*where)),Putchr('\n', (*where));
break ;
case substring:
(void)fprintf((*where).fp, "%*c", indfor(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "CALL PCK_SUBSTRING_FOR"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "CALL UPK_SUBSTRING_FOR"), Putl((*where), 0);
(void)fprintf((*where).fp, "(RPC_P_BUF,A_"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(',', (*where));
continuation();
(void)fprintf((*where).fp, "S_"), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, ",L_"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(')', (*where)),Putchr('\n', (*where));
break ;
default:
Caseerror(Line);
}
}
}
void
gen_pack_for(where, head, dirn, topack)
text *where;
ptr_idlist head;
attr_type dirn;
boolean topack;
{
expression expr;
do {
{
register struct S77 *W105 = &(*head);
register struct S75 *W106 = &(*W105->id_type);
expr.len = 0;
append_name(&expr, head->name);
if ((W105->attr == inoutok) || (W105->attr == dirn)) {
deref = (boolean)(client && !(runoptions.A[(int)(byvalue)].value && (W105->attr == intok)));
gen_pack_type_for(&(*where), expr, W105->id_type, 1, topack);
}
}
head = head->next;
} while (!(head == (struct S77 *)NIL));
}
void
gen_type_decl_for(expr, pt, level)
expression expr;
ptr_defined_type pt;
integer level;
{
ptr_defined_type scan;
expression exp2;
{
register struct S75 *W107 = &(*pt);
switch ((int)(W107->typ_basic_type)) {
case chartok: case bytetok: case shortok: case integertok:
case real32tok: case real48tok: case real64tok: case real128tok:
case longtok:
(void)fprintf(op_file.fp, "%*c", indfor(level), ' '), Putl(op_file, 0);
switch ((int)(W107->typ_basic_type)) {
case chartok:
(void)fprintf(op_file.fp, "CHARACTER*1"), Putl(op_file, 0);
break ;
case bytetok:
(void)fprintf(op_file.fp, "BYTE"), Putl(op_file, 0);
break ;
case integertok:
(void)fprintf(op_file.fp, "INTEGER"), Putl(op_file, 0);
break ;
case real32tok:
(void)fprintf(op_file.fp, "REAL"), Putl(op_file, 0);
break ;
case real48tok:
(void)fprintf(op_file.fp, "DOUBLE"), Putl(op_file, 0);
break ;
case real64tok:
(void)fprintf(op_file.fp, "DOUBLE"), Putl(op_file, 0);
break ;
case real128tok:
(void)fprintf(op_file.fp, "DOUBLE"), Putl(op_file, 0);
break ;
case shortok:
(void)fprintf(op_file.fp, "INTEGER*2"), Putl(op_file, 0);
break ;
case longtok:
(void)fprintf(op_file.fp, "INTEGER*4"), Putl(op_file, 0);
break ;
default:
Caseerror(Line);
}
Putchr(' ', op_file);
write_exp(&op_file, &expr);
Putchr('\n', op_file);
break ;
case substring: case stringtok:
(void)fprintf(op_file.fp, "%*c", indfor(level), ' '), Putl(op_file, 0);
if (client && (level == 1))
(void)fprintf(op_file.fp, "CHARACTER*(*) "), Putl(op_file, 0);
else
(void)fprintf(op_file.fp, "CHARACTER*%1d ", (W107->U.V4.typ_high)), Putl(op_file, 0);
write_exp(&op_file, &expr);
Putchr('\n', op_file);
break ;
case sequence: case arraytok:
exp2 = expr;
append_1(&exp2, '(');
append_decimal(&exp2, W107->U.V4.typ_high - W107->U.V4.typ_low + 1);
scan = W107->typ_subtype;
while (scan->typ_basic_type == arraytok) {
append_1(&exp2, ',');
append_decimal(&exp2, scan->U.V4.typ_high - scan->U.V4.typ_low + 1);
scan = scan->typ_subtype;
}
append_1(&exp2, ')');
gen_type_decl_for(exp2, scan, level);
break ;
case accesstok:
codefor_error(*((error_string *)STRALIGN("Package has pointers: Can't make FORTRAN stubs. ")));
break ;
case recordtok:
(void)fprintf(op_file.fp, "%*cRECORD ", indfor(level), ' '), Putl(op_file, 0);
if (W107->typ_name == (struct S76 *)NIL)
codefor_error(*((error_string *)STRALIGN("Every structure must be named for VAX/FORTRAN. ")));
else {
Putchr('/', op_file);
write_name(&op_file, &W107->typ_name->nty_name);
(void)fprintf(op_file.fp, "/ "), Putl(op_file, 0);
}
write_exp(&op_file, &expr);
Putchr('\n', op_file);
break ;
default:
Caseerror(Line);
}
}
}
void
gen_client_common()
{
(void)fprintf(op_file.fp, " COMMON /C_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, "/ H_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " INTEGER H_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
}
void
gen_server_common()
{
(void)fprintf(op_file.fp, " COMMON /S_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, "/ P_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " INTEGER P_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
}
void gen_dummies();
void
comma_cont(name)
id_name name;
{
Putchr(',', op_file);
(*G109_col) = (*G109_col) + 1;
if ((*G109_col) + name.len > 65) {
continuation();
(*G109_col) = 6;
}
}
void
gen_dummies(head)
ptr_idlist head;
{
integer col;
ptr_idlist scan;
integer *F110;
F110 = G109_col;
G109_col = &col;
if (head != (struct S77 *)NIL) {
scan = head;
Putchr('(', op_file);
(*G109_col) = 40;
while (scan != (struct S77 *)NIL) {
if (Member((unsigned)(scan->id_type->typ_basic_type), Conset[58]))
(void)fprintf(op_file.fp, "A_"), Putl(op_file, 0);
write_name(&op_file, &scan->name);
(*G109_col) = (*G109_col) + scan->name.len + 2;
if (scan->id_type->typ_basic_type == substring) {
comma_cont(scan->name);
(void)fprintf(op_file.fp, "S_"), Putl(op_file, 0);
write_name(&op_file, &scan->name);
(*G109_col) = (*G109_col) + scan->name.len + 2;
}
if (Member((unsigned)(scan->id_type->typ_basic_type), Conset[59])) {
comma_cont(scan->name);
(void)fprintf(op_file.fp, "L_"), Putl(op_file, 0);
write_name(&op_file, &scan->name);
(*G109_col) = (*G109_col) + scan->name.len + 2;
}
scan = scan->next;
if ((scan != (struct S77 *)NIL))
comma_cont(scan->name);
}
Putchr(')', op_file);
}
G109_col = F110;
}
void
gen_params_for(head)
ptr_idlist head;
{
expression a_expr, l_expr, s_expr, expr;
integer a;
ptr_idlist scan;
char ch;
boolean simple_ref;
boolean composite_ref;
scan = head;
while (scan != (struct S77 *)NIL) {
{
register struct S75 *W108 = &(*scan->id_type);
expr.len = 0;
append_name(&expr, scan->name);
l_expr = expr;
prepend_1(&l_expr, '_');
s_expr = l_expr;
a_expr = l_expr;
prepend_1(&l_expr, 'L');
prepend_1(&s_expr, 'S');
prepend_1(&a_expr, 'A');
switch ((int)(W108->typ_basic_type)) {
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, 1);
break ;
case sequence:
gen_type_decl_for(a_expr, scan->id_type, 1);
gen_type_decl_for(l_expr, simple_descriptor.A[(int)(integertok)], 1);
break ;
case substring:
gen_type_decl_for(a_expr, scan->id_type, 1);
gen_type_decl_for(s_expr, simple_descriptor.A[(int)(integertok)], 1);
gen_type_decl_for(l_expr, simple_descriptor.A[(int)(integertok)], 1);
break ;
default:
Caseerror(Line);
}
}
scan = scan->next;
}
}
void
gen_struct_for(pt, level)
ptr_defined_type pt;
integer level;
{
ptr_named_type scan;
expression exp2;
{
register struct S75 *W109 = &(*pt);
if (W109->typ_basic_type == recordtok) {
(void)fprintf(op_file.fp, "%*cSTRUCTURE ", indfor(level), ' '), Putl(op_file, 0);
if (W109->typ_name == (struct S76 *)NIL)
codefor_error(*((error_string *)STRALIGN("Every structure must be named for VAX/FORTRAN. ")));
else {
Putchr('/', op_file);
write_name(&op_file, &W109->typ_name->nty_name);
(void)fprintf(op_file.fp, "/ "), Putl(op_file, 0);
}
Putchr('\n', op_file);
scan = W109->U.V5.typ_fields;
while (scan != (struct S76 *)NIL) {
exp2.len = 0;
append_name(&exp2, scan->nty_name);
gen_type_decl_for(exp2, scan->nty_type, level + 1);
scan = scan->nty_next;
}
(void)fprintf(op_file.fp, "%*cEND STRUCTURE\n", indfor(level), ' '), Putl(op_file, 1);
}
}
}
void
generate_types_for()
{
ptr_named_type scan;
expression expr;
scan = typeptr;
while (scan != (struct S76 *)NIL)
{
register struct S76 *W110 = &(*scan);
register struct S75 *W111 = &(*W110->nty_type);
if (W111->typ_basic_type == recordtok) {
gen_struct_for(W110->nty_type, 1);
Putchr('\n', op_file);
}
scan = W110->nty_next;
}
}
void client_gen_for();
void
P62_gen_client_block(ptr)
ptr_block_table ptr;
{
register integer a;
expression expr;
{
register struct S78 *W112 = &(*ptr);
(void)fprintf(op_file.fp, "%*c", indfor(1), ' '), Putl(op_file, 0);
if (W112->b_type == functok) {
switch ((int)(W112->C33_return)) {
case chartok:
(void)fprintf(op_file.fp, "CHARACTER*1"), Putl(op_file, 0);
break ;
case bytetok: case shortok: case longtok: case integertok:
(void)fprintf(op_file.fp, "INTEGER"), Putl(op_file, 0);
break ;
case real32tok:
(void)fprintf(op_file.fp, "REAL"), Putl(op_file, 0);
break ;
case real48tok: case real64tok: case real128tok:
(void)fprintf(op_file.fp, "DOUBLE"), Putl(op_file, 0);
break ;
default:
Caseerror(Line);
}
(void)fprintf(op_file.fp, " FUNCTION "), Putl(op_file, 0);
write_name(&op_file, &W112->name);
switch ((int)(W112->C33_return)) {
case chartok:
break ;
case bytetok:
(void)fprintf(op_file.fp, "*1"), Putl(op_file, 0);
break ;
case integertok: case real32tok: case real48tok: case real64tok:
case real128tok:
break ;
case shortok:
(void)fprintf(op_file.fp, "*2"), Putl(op_file, 0);
break ;
case longtok:
(void)fprintf(op_file.fp, "*4"), Putl(op_file, 0);
break ;
default:
Caseerror(Line);
}
} else {
(void)fprintf(op_file.fp, "SUBROUTINE "), Putl(op_file, 0);
write_name(&op_file, &W112->name);
}
gen_dummies(W112->list);
Putchr('\n', op_file);
gen_client_common();
generate_types_for();
gen_params_for(W112->list);
(void)fprintf(op_file.fp, " INTEGER RPC_P_BUF"), Putl(op_file, 0);
{
integer B113 = 1,
B114 = W112->blk_nesting;
if (B113 <= B114)
for (a = B113; ; a++) {
(void)fprintf(op_file.fp, ",RPC_%c", (unsigned)('A') - 1 + a), Putl(op_file, 0);
if (a == B114) break;
}
}
Putchr('\n', op_file);
if (W112->b_type == functok) {
format(&expr, *((template_type *)STRALIGN("RPC_RET ")));
gen_type_decl_for(expr, simple_descriptor.A[(int)(W112->C33_return)], 1);
}
if (W112->blk_status_param != (struct S77 *)NIL) {
(void)fprintf(op_file.fp, " INTEGER*4 RPC_CALL_STATUS\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
(void)fprintf(op_file.fp, " CALL RPC_BEGIN_CALL_FOR(RPC_P_BUF, H_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ",%1d,%1d,%1d,%1d)\n", W112->blk_max_in, W112->blk_max_out, version_num, (*G111_proc_number)), Putl(op_file, 1);
if (W112->list != (struct S77 *)NIL)
gen_pack_for(&op_file, W112->list, intok, true);
if (W112->blk_status_param != (struct S77 *)NIL) {
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
write_name(&op_file, &W112->blk_status_param->name);
(void)fprintf(op_file.fp, "=RPC_CALL_STATUS(H_"), Putl(op_file, 0);
} else
if (W112->blk_cast) {
(void)fprintf(op_file.fp, " CALL RPC_CAST(H_"), Putl(op_file, 0);
} else {
(void)fprintf(op_file.fp, " CALL RPC_CALL(H_"), Putl(op_file, 0);
}
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ",RPC_P_BUF"), Putl(op_file, 0);
if (!W112->blk_cast)
(void)fprintf(op_file.fp, ",%1d", W112->blk_timeout), Putl(op_file, 0);
Putchr(')', op_file),Putchr('\n', op_file);
if (W112->blk_status_param != (struct S77 *)NIL) {
(void)fprintf(op_file.fp, " IF (MOD("), Putl(op_file, 0);
write_name(&op_file, &W112->blk_status_param->name);
(void)fprintf(op_file.fp, ",2).NE.0) THEN\n"), Putl(op_file, 1);
}
if (W112->b_type == functok) {
pack_simple_for(&op_file, W112->C33_return, false);
(void)fprintf(op_file.fp, "RPC_RET)\n"), Putl(op_file, 1);
}
if (W112->list != (struct S77 *)NIL)
gen_pack_for(&op_file, W112->list, outok, false);
if (W112->blk_status_param != (struct S77 *)NIL)
(void)fprintf(op_file.fp, " END IF\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " CALL RPC_END_CALL_FOR(RPC_P_BUF)\n"), Putl(op_file, 1);
if (W112->b_type == functok) {
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
write_name(&op_file, &W112->name);
(void)fprintf(op_file.fp, "=RPC_RET\n"), Putl(op_file, 1);
}
(void)fprintf(op_file.fp, " RETURN\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " END\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
}
void
P63_gen_open()
{
if (!runoptions.A[(int)(noautoinit)].value)
(void)fprintf(op_file.fp, "C Call this procedure at initialisation time ***\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " SUBROUTINE OPEN_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
gen_client_common();
(void)fprintf(op_file.fp, " INTEGER STATUS\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " CALL RPC_OPEN_FOR(STATUS,H_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(',', op_file);
continuation();
write_name_padded(&op_file, unitname, '\'');
Putchr(')', op_file),Putchr('\n', op_file);
(void)fprintf(op_file.fp, " CALL RPC_REPORT_ERROR(STATUS)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " END\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
void
P64_gen_close()
{
(void)fprintf(op_file.fp, " SUBROUTINE CLOSE_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
gen_client_common();
(void)fprintf(op_file.fp, " INTEGER STATUS\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " CALL RPC_CLOSE_FOR(STATUS,H_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(')', op_file),Putchr('\n', op_file);
(void)fprintf(op_file.fp, " CALL RPC_REPORT_ERROR(STATUS)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " END\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
void
client_gen_for()
{
ptr_block_table scan;
integer proc_number;
integer *F112;
F112 = G111_proc_number;
G111_proc_number = &proc_number;
next_label = 100;
(void)fprintf(op_file.fp, "C CLIENT STUB routines for package "), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "C ====================\n"), Putl(op_file, 1);
Putchr('C', op_file),Putchr('\n', op_file);
(void)fprintf(op_file.fp, "C Generated automatically by the RPC Compiler\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "C \n"), Putl(op_file, 1);
(*G111_proc_number) = 1;
scan = blockptr;
while (scan != (struct S78 *)NIL) {
P62_gen_client_block(scan);
(*G111_proc_number) = (*G111_proc_number) + 1;
scan = scan->next;
}
P63_gen_open();
P64_gen_close();
G111_proc_number = F112;
}
void server_gen_for();
void
P65_gen_r_routine()
{
register integer a;
expression expr;
(void)fprintf(op_file.fp, " SUBROUTINE R_"), Putl(op_file, 0);
write_name(&op_file, &(*G113_scan)->name);
(void)fprintf(op_file.fp, "(RPC_P_BUF)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " INTEGER RPC_P_BUF"), Putl(op_file, 0);
if ((*G113_scan)->b_type == functok) {
Putchr('\n', op_file);
expr.len = 0;
append_name(&expr, (*G113_scan)->name);
gen_type_decl_for(expr, simple_descriptor.A[(int)((*G113_scan)->C33_return)], 1);
}
{
integer B115 = 1,
B116 = (*G113_scan)->blk_nesting;
if (B115 <= B116)
for (a = B115; ; a++) {
(void)fprintf(op_file.fp, ",RPC_%c", (unsigned)('A') - 1 + a), Putl(op_file, 0);
if (a == B116) break;
}
}
Putchr('\n', op_file);
generate_types_for();
gen_params_for((*G113_scan)->list);
if ((*G113_scan)->list != (struct S77 *)NIL)
gen_pack_for(&op_file, (*G113_scan)->list, intok, false);
(void)fprintf(op_file.fp, " CALL RPC_INIT_RETURN_FOR(RPC_P_BUF)\n"), Putl(op_file, 1);
if (((*G113_scan)->b_type == proctok) && (*G113_scan)->in_only)
if ((runoptions.A[(int)(concurrent)].value || (*G113_scan)->blk_concurrent))
(void)fprintf(op_file.fp, " CALL RPC_EARLY_RETURN(RPC_P_BUF)\n"), Putl(op_file, 1);
else
if ((*G113_scan)->blk_cast)
(void)fprintf(op_file.fp, " CALL RPC_NO_RETURN(RPC_P_BUF)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if ((*G113_scan)->b_type == functok)
pack_simple_for(&op_file, (*G113_scan)->C33_return, true);
else
(void)fprintf(op_file.fp, "CALL "), Putl(op_file, 0);
write_name(&op_file, &(*G113_scan)->name);
gen_dummies((*G113_scan)->list);
if ((*G113_scan)->b_type == functok) {
if (((*G113_scan)->list == (struct S77 *)NIL))
(void)fprintf(op_file.fp, "()"), Putl(op_file, 0);
Putchr(')', op_file);
}
Putchr('\n', op_file);
if ((*G113_scan)->list != (struct S77 *)NIL)
gen_pack_for(&op_file, (*G113_scan)->list, outok, true);
(void)fprintf(op_file.fp, " END\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
void
server_gen_for()
{
integer proc_num;
register integer i;
ptr_block_table scan;
ptr_block_table *F114;
F114 = G113_scan;
G113_scan = &scan;
next_label = 100;
(void)fprintf(op_file.fp, "C SERVER STUB routines for package "), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "C ====================\n"), Putl(op_file, 1);
Putchr('C', op_file),Putchr('\n', op_file);
(void)fprintf(op_file.fp, "C Generated automatically by the RPC Compiler\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "C \n"), Putl(op_file, 1);
(*G113_scan) = blockptr;
proc_num = 0;
while ((*G113_scan) != (struct S78 *)NIL) {
proc_num = proc_num + 1;
P65_gen_r_routine();
(*G113_scan) = (*G113_scan)->next;
}
Putchr('C', op_file),Putchr('\n', op_file);
(void)fprintf(op_file.fp, "C Main stub entry point\n"), Putl(op_file, 1);
Putchr('C', op_file),Putchr('\n', op_file);
(void)fprintf(op_file.fp, " SUBROUTINE R_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, "(RPC_P_BUF)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " INTEGER RPC_P_BUF\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " INTEGER*2 RPC_REQUEST\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " INTEGER*4 STATUS\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " INTEGER RPC_S_UNSUPPORTED_VERSION\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " PARAMETER(RPC_S_UNSUPPORTED_VERSION=139624458)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " INTEGER RPC_S_BAD_PROCEDURE_NUMBER\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " PARAMETER(RPC_S_BAD_PROCEDURE_NUMBER=139624466)\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " CALL UPK_SHORT_FOR(RPC_P_BUF, RPC_REQUEST)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " IF ((RPC_REQUEST.NE.0).AND.(RPC_REQUEST.NE.%1d)) THEN\n", version_num), Putl(op_file, 1);
(void)fprintf(op_file.fp, " CALL RPC_SET_ERROR(RPC_P_BUF,RPC_S_UNSUPPORTED_VERSION)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " ELSE\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " CALL UPK_SHORT_FOR(RPC_P_BUF, RPC_REQUEST)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " IF ((RPC_REQUEST.LE.0).OR.(RPC_REQUEST.GT.%1d)) THEN\n", proc_num), Putl(op_file, 1);
(void)fprintf(op_file.fp, " CALL RPC_SET_ERROR(RPC_P_BUF,RPC_S_BAD_PROCEDURE_NUMBER)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " ELSE\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " GOTO(10"), Putl(op_file, 0);
{
integer B117 = 2,
B118 = proc_num;
if (B117 <= B118)
for (i = B117; ; i++) {
if ((i % 10) == 0) {
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " + "), Putl(op_file, 0);
}
(void)fprintf(op_file.fp, ",%1d", i * 10), Putl(op_file, 0);
if (i == B118) break;
}
}
(void)fprintf(op_file.fp, "),RPC_REQUEST\n"), Putl(op_file, 1);
(*G113_scan) = blockptr;
{
integer B119 = 1,
B120 = proc_num;
if (B119 <= B120)
for (i = B119; ; i++) {
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "%5d CALL R_", i * 10), Putl(op_file, 0);
write_name(&op_file, &(*G113_scan)->name);
(void)fprintf(op_file.fp, "(RPC_P_BUF)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " GOTO 888\n"), Putl(op_file, 1);
(*G113_scan) = (*G113_scan)->next;
if (i == B120) break;
}
}
(void)fprintf(op_file.fp, " 888 CONTINUE\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " END IF\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " END IF\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " END\n"), Putl(op_file, 1);
Putchr('\n', op_file);
if (!runoptions.A[(int)(noautoinit)].value)
(void)fprintf(op_file.fp, "C Call this procedure at initialisation time ***\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " SUBROUTINE ATTACH_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
gen_server_common();
(void)fprintf(op_file.fp, " EXTERNAL R_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " INTEGER STATUS\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " CALL RPC_ATTACH_STUB_FOR(STATUS,R_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(',', op_file);
continuation();
write_name_padded(&op_file, unitname, '\'');
(void)fprintf(op_file.fp, ",P_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(')', op_file),Putchr('\n', op_file);
(void)fprintf(op_file.fp, " CALL RPC_REPORT_ERROR(STATUS)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " END\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " SUBROUTINE DETACH_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
gen_server_common();
(void)fprintf(op_file.fp, " CALL RPC_DETACH_STUB_FOR(P_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(')', op_file),Putchr('\n', op_file);
(void)fprintf(op_file.fp, " END\n"), Putl(op_file, 1);
G113_scan = F114;
}
void
write_name_pils(where, name)
text *where;
id_name *name;
{
register integer a;
{
register struct S102 *W121 = &(*name);
{
integer B122 = 1,
B123 = W121->len;
if (B122 <= B123)
for (a = B122; ; a++) {
Putchr(W121->str.A[a - 1], (*where));
if (a == B123) break;
}
}
}
}
void
write_exp_pils(where, expr)
text *where;
expression *expr;
{
register integer a;
{
register struct S106 *W124 = &(*expr);
{
integer B125 = 1,
B126 = W124->len;
if (B125 <= B126)
for (a = B125; ; a++) {
Putchr(W124->str.A[a - 1], (*where));
if (a == B126) break;
}
}
}
}
void
write_name_padded_pils(op_file, name, ch)
text *op_file;
id_name name;
char ch;
{
Putchr(ch, (*op_file));
write_name(&(*op_file), &name);
(void)fprintf((*op_file).fp, "%*c", rpc_name_length + 1 - name.len, ch), Putl((*op_file), 0);
}
void
code_error_pils(why)
error_string why;
{
(void)fprintf(output.fp, " RPCC: **** Error: %.48s\n", why.A), Putl(output, 1);
(void)fprintf(output.fp, " (Error detected at PILS code generator stage.)\n"), Putl(output, 1);
abort();
}
integer
ind_pils(level)
integer level;
{
register integer R99;
R99 = (level) * 3;
return R99;
}
void
append_index_pils(expr, level)
expression *expr;
integer level;
{
char ch;
format(&(*expr), *((template_type *)STRALIGN("$(rpc_ ")));
append_1(&(*expr), (unsigned)('a') + level - 1);
append_1(&(*expr), ')');
}
void
pack_simple_pils(where, what, topack)
text *where;
type_token what;
boolean topack;
{
if (topack)
(void)fprintf((*where).fp, "pck_"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "upk_"), Putl((*where), 0);
switch ((int)(what)) {
case chartok:
(void)fprintf((*where).fp, "char"), Putl((*where), 0);
break ;
case bytetok:
(void)fprintf((*where).fp, "byte"), Putl((*where), 0);
break ;
case shortok:
(void)fprintf((*where).fp, "short"), Putl((*where), 0);
break ;
case integertok:
(void)fprintf((*where).fp, "integer"), Putl((*where), 0);
break ;
case real32tok:
(void)fprintf((*where).fp, "real32"), Putl((*where), 0);
break ;
case real48tok:
(void)fprintf((*where).fp, "real48"), Putl((*where), 0);
break ;
case real64tok:
(void)fprintf((*where).fp, "real64"), Putl((*where), 0);
break ;
case real128tok:
(void)fprintf((*where).fp, "real128"), Putl((*where), 0);
break ;
case longtok:
(void)fprintf((*where).fp, "long"), Putl((*where), 0);
break ;
default:
Caseerror(Line);
}
(void)fprintf((*where).fp, "(rpc_p_buf,"), Putl((*where), 0);
}
void
gen_align_pils(power, level)
integer power;
integer level;
{
(void)fprintf(op_file.fp, "%*crpc_align(rpc_p_buf,%1d)\n", ind_pils(level), ' ', power), Putl(op_file, 1);
}
void
gen_pack_type_pils(where, expr, typ, level, topack)
text *where;
expression expr;
ptr_defined_type typ;
integer level;
boolean topack;
{
char ch;
ptr_named_type scan;
ptr_defined_type element;
integer depth;
expression exp2;
expression l_expr, s_expr;
register integer i;
ch = (unsigned)('a') + level - 1;
l_expr = expr;
prepend_1(&l_expr, '_');
s_expr = l_expr;
prepend_1(&l_expr, 'L');
prepend_1(&s_expr, 'S');
{
register struct S75 *W127 = &(*typ);
if (W127->typ_external) {
(void)fprintf((*where).fp, "%*c", ind_pils(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "pck_"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "upk_"), Putl((*where), 0);
write_name(&op_file, &W127->typ_name->nty_name);
(void)fprintf((*where).fp, "(rpc_p_buf,"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(')', (*where)),Putchr('\n', (*where));
} else
switch ((int)(W127->typ_basic_type)) {
case chartok:
(void)fprintf((*where).fp, "%*c", ind_pils(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "pck"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "upk"), Putl((*where), 0);
(void)fprintf((*where).fp, "_char_PILS(rpc_p_buf,"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(')', (*where)),Putchr('\n', (*where));
break ;
case bytetok:
(void)fprintf((*where).fp, "%*c", ind_pils(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "pck"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "upk"), Putl((*where), 0);
(void)fprintf((*where).fp, "_byte_PILS(rpc_p_buf,"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(')', (*where)),Putchr('\n', (*where));
break ;
case shortok: case integertok: case real32tok: case real48tok:
case real64tok: case real128tok: case longtok:
(void)fprintf((*where).fp, "%*c", ind_pils(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "pck"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "upk"), Putl((*where), 0);
{
register struct S102 *W128 = &W127->typ_name->nty_name;
{
integer B129 = 4,
B130 = W128->len;
if (B129 <= B130)
for (i = B129; ; i++) {
Putchr(W128->str.A[i - 1], (*where));
if (i == B130) break;
}
}
}
(void)fprintf((*where).fp, "(rpc_p_buf,"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(')', (*where)),Putchr('\n', (*where));
break ;
case arraytok:
exp2 = expr;
depth = level;
ch = (unsigned)('a') + depth - 1;
element = W127->typ_subtype;
format(&exp2, *((template_type *)STRALIGN("$(rpc_ ")));
append_1(&exp2, ch);
(void)fprintf((*where).fp, "%*c", ind_pils(depth), ' '), Putl((*where), 0);
(void)fprintf((*where).fp, "FOR rpc_%c=1 TO %1d\n", ch, W127->U.V4.typ_high - W127->U.V4.typ_low + 1), Putl((*where), 1);
while (element->typ_basic_type == arraytok)
{
register struct S75 *W131 = &(*element);
depth = depth + 1;
ch = (unsigned)('a') + depth - 1;
(void)fprintf((*where).fp, "%*c", ind_pils(depth), ' '), Putl((*where), 0);
(void)fprintf((*where).fp, "FOR rpc_%c=1 TO %1d\n", ch, W131->U.V4.typ_high - W131->U.V4.typ_low + 1), Putl((*where), 1);
format(&exp2, *((template_type *)STRALIGN("$,rpc_ ")));
append_1(&exp2, ch);
element = element->typ_subtype;
}
append_1(&exp2, ')');
gen_pack_type_pils(&(*where), exp2, element, depth + 1, topack);
while (depth >= level) {
(void)fprintf((*where).fp, "%*cENDFOR\n", ind_pils(depth), ' '), Putl((*where), 1);
depth = depth - 1;
}
break ;
case recordtok:
code_error_pils(*((error_string *)STRALIGN("No RECORD (STRUCTURE) type exists in PILS! ")));
break ;
case accesstok:
code_error_pils(*((error_string *)STRALIGN("No ACCESS (POINTER) type exists in PILS! ")));
break ;
case sequence:
if (level > 1)
code_error_pils(*((error_string *)STRALIGN("SEQUENCE type not allowed within composite type.")));
gen_pack_type_pils(&(*where), l_expr, simple_descriptor.A[(int)(integertok)], level, topack);
exp2 = expr;
format(&exp2, *((template_type *)STRALIGN("A_$ ")));
append_index_pils(&exp2, level);
(void)fprintf((*where).fp, "%*c", ind_pils(level), ' '), Putl((*where), 0);
(void)fprintf((*where).fp, "FOR rpc_%c=1 TO L_", ch), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr('\n', (*where));
gen_pack_type_pils(&(*where), exp2, W127->typ_subtype, level + 1, topack);
(void)fprintf((*where).fp, "%*cENDFOR\n", ind_pils(level), ' '), Putl((*where), 1);
break ;
case stringtok:
(void)fprintf((*where).fp, "%*c", ind_pils(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "pck_string"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "upk_string"), Putl((*where), 0);
(void)fprintf((*where).fp, "(rpc_p_buf,"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(')', (*where)),Putchr('\n', (*where));
break ;
case substring:
(void)fprintf((*where).fp, "%*c", ind_pils(level), ' '), Putl((*where), 0);
if (topack)
(void)fprintf((*where).fp, "pck_substring"), Putl((*where), 0);
else
(void)fprintf((*where).fp, "upk_substring"), Putl((*where), 0);
(void)fprintf((*where).fp, "(rpc_p_buf,A_"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(',', (*where));
(void)fprintf((*where).fp, "S_"), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, ",L_"), Putl((*where), 0);
write_exp(&(*where), &expr);
Putchr(')', (*where)),Putchr('\n', (*where));
break ;
default:
Caseerror(Line);
}
}
}
void
gen_pack_pils(where, head, dirn, topack)
text *where;
ptr_idlist head;
attr_type dirn;
boolean topack;
{
expression expr;
do {
{
register struct S77 *W132 = &(*head);
register struct S75 *W133 = &(*W132->id_type);
expr.len = 0;
append_name(&expr, head->name);
if ((W132->attr == inoutok) || (W132->attr == dirn)) {
deref = (boolean)(client && !(runoptions.A[(int)(byvalue)].value && (W132->attr == intok)));
gen_pack_type_pils(&(*where), expr, W132->id_type, 1, topack);
}
}
head = head->next;
} while (!(head == (struct S77 *)NIL));
}
void
gen_type_decl_pils(expr, pt, level)
expression expr;
ptr_defined_type pt;
integer level;
{
ptr_defined_type scan;
expression exp2;
{
register struct S75 *W134 = &(*pt);
switch ((int)(W134->typ_basic_type)) {
case chartok: case bytetok: case shortok: case integertok:
case real32tok: case real48tok: case real64tok: case real128tok:
case longtok:
switch ((int)(W134->typ_basic_type)) {
case chartok:
(void)fprintf(op_file.fp, "int16"), Putl(op_file, 0);
break ;
case bytetok:
(void)fprintf(op_file.fp, "int16"), Putl(op_file, 0);
break ;
case integertok:
(void)fprintf(op_file.fp, "INT"), Putl(op_file, 0);
break ;
case real32tok:
(void)fprintf(op_file.fp, "REAL"), Putl(op_file, 0);
break ;
case real48tok:
(void)fprintf(op_file.fp, "REAL"), Putl(op_file, 0);
break ;
case real64tok:
(void)fprintf(op_file.fp, "REAL"), Putl(op_file, 0);
break ;
case real128tok:
(void)fprintf(op_file.fp, "REAL"), Putl(op_file, 0);
break ;
case shortok:
(void)fprintf(op_file.fp, "INT16"), Putl(op_file, 0);
break ;
case longtok:
(void)fprintf(op_file.fp, "INT32"), Putl(op_file, 0);
break ;
default:
Caseerror(Line);
}
Putchr(' ', op_file);
write_exp(&op_file, &expr);
break ;
case substring: case stringtok:
(void)fprintf(op_file.fp, "CHAR "), Putl(op_file, 0);
write_exp(&op_file, &expr);
break ;
case sequence: case arraytok:
exp2 = expr;
append_1(&exp2, '(');
append_decimal(&exp2, W134->U.V4.typ_high - W134->U.V4.typ_low + 1);
scan = W134->typ_subtype;
while (scan->typ_basic_type == arraytok) {
append_1(&exp2, ',');
append_decimal(&exp2, scan->U.V4.typ_high - W134->U.V4.typ_low + 1);
scan = scan->typ_subtype;
}
append_1(&exp2, ')');
gen_type_decl_pils(exp2, scan, level);
break ;
case accesstok:
code_error_pils(*((error_string *)STRALIGN("Package has pointers: Can't make PILS stubs. ")));
break ;
case recordtok:
code_error_pils(*((error_string *)STRALIGN("Package has records: Can't make PILS stubs. ")));
break ;
default:
Caseerror(Line);
}
}
}
void
gen_params_pils(head)
ptr_idlist head;
{
expression a_expr, l_expr, s_expr, expr;
integer a;
ptr_idlist scan;
char ch;
boolean simple_ref;
boolean composite_ref;
scan = head;
if (client)
Putchr('(', op_file);
while (scan != (struct S77 *)NIL) {
if (client)
switch ((int)(scan->attr)) {
case intok:
(void)fprintf(op_file.fp, "IN "), Putl(op_file, 0);
break ;
case outok:
(void)fprintf(op_file.fp, "OUT "), Putl(op_file, 0);
break ;
case inoutok:
(void)fprintf(op_file.fp, "INOUT "), Putl(op_file, 0);
break ;
default:
Caseerror(Line);
}
{
register struct S75 *W135 = &(*scan->id_type);
expr.len = 0;
append_name(&expr, scan->name);
l_expr = expr;
prepend_1(&l_expr, '_');
s_expr = l_expr;
a_expr = l_expr;
prepend_1(&l_expr, 'L');
prepend_1(&s_expr, 'S');
prepend_1(&a_expr, 'A');
switch ((int)(W135->typ_basic_type)) {
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, 1);
break ;
case sequence:
gen_type_decl_pils(a_expr, scan->id_type, 1);
if (client)
Putchr(',', op_file);
else
Putchr(';', op_file);
gen_type_decl_pils(l_expr, simple_descriptor.A[(int)(integertok)], 1);
break ;
case substring:
gen_type_decl_pils(a_expr, scan->id_type, 1);
if (client)
Putchr(',', op_file);
else
Putchr(';', op_file);
gen_type_decl_pils(s_expr, simple_descriptor.A[(int)(integertok)], 1);
if (client)
Putchr(',', op_file);
else
Putchr(';', op_file);
gen_type_decl_pils(l_expr, simple_descriptor.A[(int)(integertok)], 1);
break ;
default:
Caseerror(Line);
}
}
scan = scan->next;
if (scan != (struct S77 *)NIL)
if (client)
Putchr(',', op_file);
else
Putchr(';', op_file);
}
if (client)
Putchr(')', op_file);
Putchr('\n', op_file);
}
void
gen_formals(head)
ptr_idlist head;
{
ptr_idlist scan;
if (head != (struct S77 *)NIL) {
scan = head;
Putchr('(', op_file);
while (scan != (struct S77 *)NIL) {
if (Member((unsigned)(scan->id_type->typ_basic_type), Conset[60]))
(void)fprintf(op_file.fp, "A_"), Putl(op_file, 0);
write_name(&op_file, &scan->name);
if (scan->id_type->typ_basic_type == substring) {
(void)fprintf(op_file.fp, ", S_"), Putl(op_file, 0);
write_name(&op_file, &scan->name);
}
if (Member((unsigned)(scan->id_type->typ_basic_type), Conset[61])) {
(void)fprintf(op_file.fp, ", L_"), Putl(op_file, 0);
write_name(&op_file, &scan->name);
}
scan = scan->next;
if (scan != (struct S77 *)NIL)
Putchr(',', op_file);
}
Putchr(')', op_file);
}
}
void
gen_struct_pils(pt, level)
ptr_defined_type pt;
integer level;
{
ptr_named_type scan;
expression exp2;
}
void
generate_types_pils()
{
}
void client_generator_pils();
void
P66_gen_client_block(ptr)
ptr_block_table ptr;
{
register integer a;
expression expr;
{
register struct S78 *W136 = &(*ptr);
if (W136->b_type == functok) {
(void)fprintf(op_file.fp, "DEF "), Putl(op_file, 0);
switch ((int)(W136->C33_return)) {
case chartok:
(void)fprintf(op_file.fp, "int16"), Putl(op_file, 0);
break ;
case bytetok:
(void)fprintf(op_file.fp, "int16"), Putl(op_file, 0);
break ;
case shortok: case integertok:
(void)fprintf(op_file.fp, "INT16"), Putl(op_file, 0);
break ;
case longtok:
(void)fprintf(op_file.fp, "INT32"), Putl(op_file, 0);
break ;
case real32tok: case real48tok: case real64tok: case real128tok:
(void)fprintf(op_file.fp, "REAL"), Putl(op_file, 0);
break ;
default:
Caseerror(Line);
}
Putchr(' ', op_file);
write_name(&op_file, &W136->name);
} else {
(void)fprintf(op_file.fp, "SUB "), Putl(op_file, 0);
write_name(&op_file, &W136->name);
}
gen_params_pils(W136->list);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " INT rpc_p_buf"), Putl(op_file, 0);
{
integer B137 = 1,
B138 = W136->blk_nesting;
if (B137 <= B138)
for (a = B137; ; a++) {
(void)fprintf(op_file.fp, ",rpc_%c", (unsigned)('a') - 1 + a), Putl(op_file, 0);
if (a == B138) break;
}
}
Putchr('\n', op_file);
if (W136->b_type == functok) {
(void)fprintf(op_file.fp, " INT rpc_ret\n"), Putl(op_file, 1);
}
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " rpc_begin_call(rpc_p_buf,h_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ",%1d,%1d,%1d,%1d)\n", W136->blk_max_in, W136->blk_max_out, version_num, (*G115_proc_number)), Putl(op_file, 1);
if (W136->list != (struct S77 *)NIL)
gen_pack_pils(&op_file, W136->list, intok, true);
if (W136->blk_cast)
(void)fprintf(op_file.fp, " rpc_cast(h_"), Putl(op_file, 0);
else
(void)fprintf(op_file.fp, " rpc_call(h_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ",rpc_p_buf"), Putl(op_file, 0);
if (!W136->blk_cast)
(void)fprintf(op_file.fp, ",%1d", W136->blk_timeout), Putl(op_file, 0);
Putchr(')', op_file),Putchr('\n', op_file);
if (W136->b_type == functok) {
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
pack_simple_pils(&op_file, W136->C33_return, false);
(void)fprintf(op_file.fp, "rpc_ret)\n"), Putl(op_file, 1);
}
if (W136->list != (struct S77 *)NIL)
gen_pack_pils(&op_file, W136->list, outok, false);
(void)fprintf(op_file.fp, " rpc_end_call(rpc_p_buf)\n"), Putl(op_file, 1);
if (W136->b_type == functok) {
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
write_name(&op_file, &W136->name);
(void)fprintf(op_file.fp, "=rpc_ret\n"), Putl(op_file, 1);
}
(void)fprintf(op_file.fp, "END"), Putl(op_file, 0);
if (W136->b_type == functok)
(void)fprintf(op_file.fp, "DEF"), Putl(op_file, 0);
else
(void)fprintf(op_file.fp, "SUB"), Putl(op_file, 0);
Putchr('\n', op_file);
Putchr('\n', op_file);
}
}
void
gen_client_header()
{
(void)fprintf(op_file.fp, "!---\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "!--- CLIENT STUB routines for package "), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "!---\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "!--- Generated automatically by the RPC Compiler\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "!---\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "OPTION IMPLICIT OFF\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "OPTION BASE 1\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "MODULE CLI"), Putl(op_file, 0);
write_name_pils(&op_file, &unitname);
Putchr('\n', op_file);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "GLOBAL INT h_"), Putl(op_file, 0);
write_name_pils(&op_file, &unitname);
Putchr('\n', op_file);
Putchr('\n', op_file);
}
void
P67_gen_open()
{
(void)fprintf(op_file.fp, "SUB open_"), Putl(op_file, 0);
write_name_pils(&op_file, &unitname);
(void)fprintf(op_file.fp, "()\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " INT status\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " CHAR service\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " service = "), Putl(op_file, 0);
write_name_padded_pils(&op_file, unitname, '"');
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " rpc_open(status,h_"), Putl(op_file, 0);
write_name_pils(&op_file, &unitname);
(void)fprintf(op_file.fp, ",service)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " rpc_report_error(status)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "ENDSUB\n"), Putl(op_file, 1);
Putchr('\n', op_file);
if (!runoptions.A[(int)(noautoinit)].value) {
(void)fprintf(op_file.fp, "!--- This procedure will be called at initialisation time ***\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "open_"), Putl(op_file, 0);
write_name_pils(&op_file, &unitname);
(void)fprintf(op_file.fp, "()\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
}
void
client_generator_pils()
{
ptr_block_table scan;
integer proc_number;
integer *F116;
F116 = G115_proc_number;
G115_proc_number = &proc_number;
gen_client_header();
(*G115_proc_number) = 1;
scan = blockptr;
while (scan != (struct S78 *)NIL) {
P66_gen_client_block(scan);
(*G115_proc_number) = (*G115_proc_number) + 1;
scan = scan->next;
}
P67_gen_open();
(void)fprintf(op_file.fp, "ENDMODULE\n"), Putl(op_file, 1);
G115_proc_number = F116;
}
void server_generator_pils();
void
P68_gen_r_routine()
{
integer b;
register integer a;
(void)fprintf(op_file.fp, "SUB r_"), Putl(op_file, 0);
write_name(&op_file, &(*G117_scan)->name);
(void)fprintf(op_file.fp, "(INOUT INT rpc_p_buf)\n"), Putl(op_file, 1);
generate_types_pils();
gen_params_pils((*G117_scan)->list);
Putchr('\n', op_file);
b = (*G117_scan)->blk_nesting;
if (b > 0)
(void)fprintf(op_file.fp, " INT rpc_a"), Putl(op_file, 0);
{
integer B139 = 2,
B140 = b;
if (B139 <= B140)
for (a = B139; ; a++) {
(void)fprintf(op_file.fp, ",rpc_%c", (unsigned)('a') - 1 + a), Putl(op_file, 0);
if (a == B140) break;
}
}
Putchr('\n', op_file);
Putchr('\n', op_file);
if ((*G117_scan)->list != (struct S77 *)NIL)
gen_pack_pils(&op_file, (*G117_scan)->list, intok, false);
(void)fprintf(op_file.fp, " rpc_init_return(rpc_p_buf)\n"), Putl(op_file, 1);
if (((*G117_scan)->b_type == proctok) && (*G117_scan)->in_only)
if (((runoptions.A[(int)(concurrent)].value) || (*G117_scan)->blk_concurrent))
(void)fprintf(op_file.fp, " rpc_early_return(rpc_p_buf)\n"), Putl(op_file, 1);
else
if ((*G117_scan)->blk_cast)
(void)fprintf(op_file.fp, " rpc_no_return(rpc_p_buf)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if ((*G117_scan)->b_type == functok)
pack_simple_pils(&op_file, (*G117_scan)->C33_return, true);
write_name(&op_file, &(*G117_scan)->name);
gen_formals((*G117_scan)->list);
if ((*G117_scan)->b_type == functok)
Putchr(')', op_file);
Putchr('\n', op_file);
if ((*G117_scan)->list != (struct S77 *)NIL)
gen_pack_pils(&op_file, (*G117_scan)->list, outok, true);
(void)fprintf(op_file.fp, "ENDSUB\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
void
P69_gen_attach()
{
if (!runoptions.A[(int)(noautoinit)].value)
(void)fprintf(op_file.fp, "!--- Call this procedure at initialisation time ***\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "SUB attach_"), Putl(op_file, 0);
write_name_pils(&op_file, &unitname);
(void)fprintf(op_file.fp, "()\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " INT status\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " CHAR service\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " service = "), Putl(op_file, 0);
write_name_padded_pils(&op_file, unitname, '"');
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " rpc_attach_stub(status,address(r_"), Putl(op_file, 0);
write_name_pils(&op_file, &unitname);
(void)fprintf(op_file.fp, "),service,program_number)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " rpc_report_error(status);\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "ENDSUB\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
void
P70_gen_detach()
{
if (!runoptions.A[(int)(noautoinit)].value)
(void)fprintf(op_file.fp, "!--- Call this procedure at exit time ***\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "SUB detach_"), Putl(op_file, 0);
write_name_pils(&op_file, &unitname);
(void)fprintf(op_file.fp, "()\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " rpc_detach_stub(program_number)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "ENDSUB\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
void
server_generator_pils()
{
integer i, proc_num;
ptr_block_table scan;
ptr_block_table *F118;
F118 = G117_scan;
G117_scan = &scan;
(void)fprintf(op_file.fp, "!---\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "!--- SERVER STUB routines for package "), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "!---\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "!--- Generated automatically by the RPC Compiler\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "!---\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "OPTION IMPLICIT OFF\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "OPTION BASE 1\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "MODULE SER"), Putl(op_file, 0);
write_name_pils(&op_file, &unitname);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "HIDDEN INT program_number\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(*G117_scan) = blockptr;
proc_num = 0;
while ((*G117_scan) != (struct S78 *)NIL) {
proc_num = proc_num + 1;
P68_gen_r_routine();
(*G117_scan) = (*G117_scan)->next;
}
(void)fprintf(op_file.fp, "!---\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "!--- Main stub entry point\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "!---\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "SUB r_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, "(INOUT INT rpc_p_buf)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " INT16 rpc_request\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " upk_short(rpc_p_buf,rpc_request)\n"), Putl(op_file, 1);
if (version_num != 0) {
(void)fprintf(op_file.fp, " IF (rpc_request # 0) AND (rpc_request # %1d) THEN\n", version_num), Putl(op_file, 1);
(void)fprintf(op_file.fp, " rpc_set_error(rpc_p_buf,rpc_s_unsupported_version)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " ELSE\n"), Putl(op_file, 1);
}
(void)fprintf(op_file.fp, " upk_short(rpc_p_buf,rpc_request)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " SELECT rpc_request\n"), Putl(op_file, 1);
(*G117_scan) = blockptr;
proc_num = 1;
while ((*G117_scan) != (struct S78 *)NIL) {
(void)fprintf(op_file.fp, " CASE %2d\n", proc_num), Putl(op_file, 1);
(void)fprintf(op_file.fp, " r_"), Putl(op_file, 0);
write_name_pils(&op_file, &(*G117_scan)->name);
(void)fprintf(op_file.fp, "(rpc_p_buf)\n"), Putl(op_file, 1);
proc_num = proc_num + 1;
(*G117_scan) = (*G117_scan)->next;
}
(void)fprintf(op_file.fp, " CASE ELSE \n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
(void)fprintf(op_file.fp, "rpc_set_error(rpc_p_buf,rpc_s_bad_procedure_number)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " ENDSELECT\n"), Putl(op_file, 1);
if (version_num != 0)
(void)fprintf(op_file.fp, " ENDIF\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "ENDSUB\n"), Putl(op_file, 1);
Putchr('\n', op_file);
P69_gen_attach();
P70_gen_detach();
(void)fprintf(op_file.fp, "ENDMODULE\n"), Putl(op_file, 1);
G117_scan = F118;
}
void
codegen_error(why)
error_string why;
{
(void)fprintf(output.fp, " RPCC: **** Error: %.48s\n", why.A), Putl(output, 1);
(void)fprintf(output.fp, " (Error detected at code generator stage.)\n"), Putl(output, 1);
abort();
}
void
writok(where, what)
text *where;
type_token what;
{
switch ((int)(what)) {
case chartok:
(void)fprintf((*where).fp, "rpc_char"), Putl((*where), 0);
break ;
case bytetok:
(void)fprintf((*where).fp, "rpc_byte"), Putl((*where), 0);
break ;
case shortok:
(void)fprintf((*where).fp, "rpc_short"), Putl((*where), 0);
break ;
case integertok:
(void)fprintf((*where).fp, "rpc_integer"), Putl((*where), 0);
break ;
case real32tok:
(void)fprintf((*where).fp, "rpc_real32"), Putl((*where), 0);
break ;
case real48tok:
(void)fprintf((*where).fp, "rpc_real48"), Putl((*where), 0);
break ;
case real64tok:
(void)fprintf((*where).fp, "rpc_real64"), Putl((*where), 0);
break ;
case real128tok:
(void)fprintf((*where).fp, "rpc_real128"), Putl((*where), 0);
break ;
case longtok:
(void)fprintf((*where).fp, "rpc_long"), Putl((*where), 0);
break ;
case arraytok: case sequence: case stringtok: case substring:
if (Member((unsigned)(omode), cmode.S))
Putchr('[', (*where));
else
(void)fprintf((*where).fp, "ARRAY [1.."), Putl((*where), 0);
break ;
case proctok:
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf((*where).fp, "PROCEDURE "), Putl((*where), 0);
break ;
case functok:
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf((*where).fp, "FUNCTION "), Putl((*where), 0);
break ;
default:
Caseerror(Line);
}
}
integer
leftin(level)
integer level;
{
register integer R100;
R100 = level * 3;
return R100;
}
void
write_declaration(where, prefix, ptr, ref)
text *where;
char prefix;
ptr_idlist ptr;
boolean ref;
{
{
register struct S77 *W141 = &(*ptr);
if (!(Member((unsigned)(omode), cmode.S))) {
if (ref)
(void)fprintf((*where).fp, "VAR "), Putl((*where), 0);
if (prefix != ' ')
(void)fprintf((*where).fp, "%c_", prefix), Putl((*where), 0);
write_name(&(*where), &W141->name);
(void)fprintf((*where).fp, ": "), Putl((*where), 0);
}
{
register struct S75 *W142 = &(*W141->id_type);
if (W142->typ_name != (struct S76 *)NIL)
write_name(&(*where), &W142->typ_name->nty_name);
else
codegen_error(*((error_string *)STRALIGN("Internal error: Unnamed type when name needed! ")));
}
if (Member((unsigned)(omode), cmode.S)) {
Putchr(' ', (*where));
if (ref)
Putchr('*', (*where));
if (prefix != ' ')
(void)fprintf((*where).fp, "%c_", prefix), Putl((*where), 0);
write_name(&(*where), &W141->name);
}
}
}
void
write_integer(where, prefix, name, ref)
text *where;
char prefix;
id_name *name;
boolean ref;
{
(void)fprintf((*where).fp, " "), Putl((*where), 0);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf((*where).fp, "rpc_integer "), Putl((*where), 0);
if (ref)
if (Member((unsigned)(omode), cmode.S))
Putchr('*', (*where));
else
(void)fprintf((*where).fp, "VAR "), Putl((*where), 0);
if (prefix != ' ')
(void)fprintf((*where).fp, "%c_", prefix), Putl((*where), 0);
write_name(&(*where), &(*name));
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf((*where).fp, " : rpc_integer"), Putl((*where), 0);
}
boolean
contains(pt, typeset)
ptr_defined_type pt;
set_of_token typeset;
{
register boolean R101;
ptr_named_type scan;
{
register struct S75 *W143 = &(*pt);
R101 = (boolean)(Member((unsigned)(W143->typ_basic_type), typeset.S));
switch ((int)(W143->typ_basic_type)) {
case chartok: case bytetok: case shortok: case integertok:
case real32tok: case real48tok: case real64tok: case real128tok:
case longtok: case substring: case sequence: case stringtok:
break ;
case accesstok: case arraytok:
if (contains(W143->typ_subtype, typeset))
R101 = true;
break ;
case recordtok:
scan = W143->U.V5.typ_fields;
while (scan != (struct S76 *)NIL)
{
register struct S76 *W144 = &(*scan);
if (contains(W144->nty_type, typeset))
R101 = true;
scan = W144->nty_next;
}
break ;
default:
Caseerror(Line);
}
}
return R101;
}
void
decl_ext_marshal()
{
ptr_named_type pnt;
register boolean topack;
pnt = typeptr;
while (pnt != (struct S76 *)NIL) {
if (pnt->nty_type->typ_external)
{
boolean B145 = false,
B146 = true;
if ((int)(B145) <= (int)(B146))
for (topack = B145; ; topack = (boolean)((int)(topack)+1)) {
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf(op_file.fp, "extern %.3s_", upkpck.A[(int)(topack)].A), Putl(op_file, 0);
write_name(&op_file, &pnt->nty_name);
(void)fprintf(op_file.fp, "();\n"), Putl(op_file, 1);
} else {
(void)fprintf(op_file.fp, "procedure %.3s_", upkpck.A[(int)(topack)].A), Putl(op_file, 0);
write_name(&op_file, &pnt->nty_name);
(void)fprintf(op_file.fp, "(var rpc_p_buf: rpc_message_pointer;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (!topack)
(void)fprintf(op_file.fp, "var "), Putl(op_file, 0);
(void)fprintf(op_file.fp, "param: "), Putl(op_file, 0);
write_name(&op_file, &pnt->nty_name);
if ((Member((unsigned)(omode), Conset[62])))
(void)fprintf(op_file.fp, "); EXTERNAL; \n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, "); EXTERN; \n"), Putl(op_file, 1);
}
if (topack == B146) break;
}
}
pnt = pnt->nty_next;
}
}
void
gen_allocate(where, expr, pt, level, do_alloc, typeset)
text *where;
expression expr;
ptr_defined_type pt;
integer level;
boolean do_alloc;
set_of_token typeset;
{
ptr_named_type scan;
expression exp2;
char ch;
ch = (unsigned)('a') + level - 1;
{
register struct S75 *W147 = &(*pt);
switch ((int)(W147->typ_basic_type)) {
case chartok: case bytetok: case shortok: case integertok:
case real32tok: case real48tok: case real64tok: case real128tok:
case longtok: case substring:
break ;
case accesstok:
if (Member((unsigned)(W147->typ_basic_type), typeset.S)) {
if (do_alloc)
codegen_error(*((error_string *)STRALIGN("Internal: Call GEN_ALLOCATE to allocate pointer")));
exp2 = expr;
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf((*where).fp, "%*cif (", leftin(level), ' '), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, ") {"), Putl((*where), 0);
format(&exp2, *((template_type *)STRALIGN("(*$) ")));
gen_allocate(&(*where), exp2, W147->typ_subtype, level + 1, do_alloc, typeset);
(void)fprintf((*where).fp, "%*cfree(", leftin(level + 1), ' '), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, ");\n"), Putl((*where), 1);
(void)fprintf((*where).fp, "%*c} /* end if */\n", leftin(level), ' '), Putl((*where), 1);
} else {
(void)fprintf((*where).fp, "%*cif ", leftin(level), ' '), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, " <> NIL then begin\n"), Putl((*where), 1);
format(&exp2, *((template_type *)STRALIGN("$^ ")));
gen_allocate(&(*where), exp2, W147->typ_subtype, level + 1, do_alloc, typeset);
(void)fprintf((*where).fp, "%*cdispose(", leftin(level + 1), ' '), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, "%*c);\n", leftin(level + 1), ' '), Putl((*where), 1);
(void)fprintf((*where).fp, "%*cend {if};\n", leftin(level), ' '), Putl((*where), 1);
}
}
break ;
case stringtok:
if ((omode == vaxvms) && (Member((unsigned)(stringtok), typeset.S))) {
if (do_alloc) {
(void)fprintf((*where).fp, " with "), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, " do begin new(StrAdr); strlen :=%1d; { Init. string descriptor }\n", W147->U.V4.typ_high), Putl((*where), 1);
(void)fprintf((*where).fp, " DType := 0; Cont := 0; end;\n"), Putl((*where), 1);
} else {
(void)fprintf((*where).fp, "%*cdispose(", leftin(level), ' '), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, ".StrAdr);\n"), Putl((*where), 1);
}
}
break ;
case arraytok:
if (contains(W147->typ_subtype, typeset)) {
exp2 = expr;
append_index(&exp2, level);
(void)fprintf((*where).fp, "%*c", leftin(level), ' '), Putl((*where), 0);
if (!(Member((unsigned)(omode), cmode.S))) {
(void)fprintf((*where).fp, "FOR rpc_%c := %1d TO %1d DO BEGIN\n", ch, W147->U.V4.typ_low, W147->U.V4.typ_high), Putl((*where), 1);
} else {
(void)fprintf((*where).fp, "for (rpc_%c = 0; rpc_%c<%1d; rpc_%c++) {", ch, ch, W147->U.V4.typ_high - W147->U.V4.typ_low + 1, ch), Putl((*where), 0);
}
gen_allocate(&(*where), exp2, W147->typ_subtype, level + 1, do_alloc, typeset);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf((*where).fp, "%*c }\n", leftin(level), ' '), Putl((*where), 1);
else
(void)fprintf((*where).fp, "%*cEND {FOR};\n", leftin(level), ' '), Putl((*where), 1);
}
break ;
case recordtok:
scan = W147->U.V5.typ_fields;
while (scan != (struct S76 *)NIL)
{
register struct S76 *W148 = &(*scan);
exp2 = expr;
append_1(&exp2, '.');
append_name(&exp2, W148->nty_name);
gen_allocate(&(*where), exp2, W148->nty_type, level, do_alloc, typeset);
scan = W148->nty_next;
}
break ;
default:
Caseerror(Line);
}
}
}
void
dopack_simple(where, what, topack)
text *where;
type_token what;
boolean topack;
{
(void)fprintf((*where).fp, "%.3s_", upkpck.A[(int)(topack)].A), Putl((*where), 0);
switch ((int)(what)) {
case chartok:
(void)fprintf((*where).fp, "char("), Putl((*where), 0);
break ;
case bytetok:
(void)fprintf((*where).fp, "byte("), Putl((*where), 0);
break ;
case shortok:
(void)fprintf((*where).fp, "short("), Putl((*where), 0);
break ;
case integertok:
(void)fprintf((*where).fp, "integer("), Putl((*where), 0);
break ;
case real32tok:
(void)fprintf((*where).fp, "real32("), Putl((*where), 0);
break ;
case real48tok:
(void)fprintf((*where).fp, "real48("), Putl((*where), 0);
break ;
case real64tok:
(void)fprintf((*where).fp, "real64("), Putl((*where), 0);
break ;
case real128tok:
(void)fprintf((*where).fp, "real128("), Putl((*where), 0);
break ;
case longtok:
(void)fprintf((*where).fp, "long("), Putl((*where), 0);
break ;
default:
Caseerror(Line);
}
(void)fprintf((*where).fp, "rpc_p_buf, "), Putl((*where), 0);
}
void
gen_align(where, power)
text *where;
integer power;
{
if (power != 1)
codegen_error(*((error_string *)STRALIGN("Internal error: Gen_align on non-word boundary! ")));
if ((boolean)((size_so_far) & 1))
size_so_far = size_so_far + 1;
if (!(Member((unsigned)(omode), cmode.S))) {
(void)fprintf((*where).fp, " IF ODD(m_index) THEN m_index:=m_index+1;\n"), Putl((*where), 1);
} else {
(void)fprintf((*where).fp, " if (rpc_p_buf->m_index%%2) rpc_p_buf->m_index++;\n"), Putl((*where), 1);
}
}
void gen_pack_type();
void
gen_pack_string(where, expr, pt, level, topack)
text *where;
expression expr;
ptr_defined_type pt;
integer level;
boolean topack;
{
char index_a, index_b;
expression a_expr, i_expr, l_expr;
index_a = (unsigned)('a') + level - 1;
index_b = (unsigned)('a') + level;
{
register struct S75 *W149 = &(*pt);
if (Member((unsigned)(omode), cmode.S)) {
a_expr = expr;
append_index(&a_expr, level);
format(&l_expr, *((template_type *)STRALIGN("rpc_ ")));
append_1(&l_expr, index_b);
if (topack) {
(void)fprintf((*where).fp, "%*cfor (rpc_%c = 0; rpc_%c <= %1d; rpc_%c++)\n", leftin(level), ' ', index_b, index_b, W149->U.V4.typ_high, index_b), Putl((*where), 1);
(void)fprintf((*where).fp, "%*cif (", leftin(level), ' '), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, "[rpc_%c] == '\\0') break;\n", index_b), Putl((*where), 1);
}
gen_pack_type(&(*where), l_expr, simple_descriptor.A[(int)(integertok)], level, false, topack, (*G129_check_subtypes));
(void)fprintf((*where).fp, "%*cfor (rpc_%c = 0; rpc_%c < rpc_%c; rpc_%c++) {\n", leftin(level), ' ', index_a, index_a, index_b, index_a), Putl((*where), 1);
gen_pack_type(&(*where), a_expr, simple_descriptor.A[(int)(chartok)], level, false, topack, (*G129_check_subtypes));
(void)fprintf((*where).fp, "%*c}\n", leftin(level), ' '), Putl((*where), 1);
if (!topack) {
(void)fprintf((*where).fp, "%*c", leftin(level), ' '), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, "[rpc_%c] = '\\0';\n", index_b), Putl((*where), 1);
}
size_so_far = (*G127_original_size) + W149->typ_max_size;
} else {
if (omode == vaxvms) {
(void)fprintf((*where).fp, "%*c%.3s", leftin(level), ' ', upkpck.A[(int)(topack)].A), Putl((*where), 0);
if ((!client && !topack))
(void)fprintf((*where).fp, "_Vstring_for(rpc_p_buf, "), Putl((*where), 0);
else
(void)fprintf((*where).fp, "_string_for(rpc_p_buf, "), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, "::rpc_string_descriptor"), Putl((*where), 0);
if ((!client && !topack))
(void)fprintf((*where).fp, ", %1d", W149->U.V4.typ_high), Putl((*where), 0);
(void)fprintf((*where).fp, ");\n"), Putl((*where), 1);
} else {
l_expr = expr;
i_expr = expr;
a_expr = expr;
if (Member((unsigned)(omode), Conset[63])) {
format(&l_expr, *((template_type *)STRALIGN("$[0] ")));
format(&i_expr, *((template_type *)STRALIGN("ord($[0]) ")));
} else
if (omode == vaxpas) {
format(&l_expr, *((template_type *)STRALIGN("$.length ")));
i_expr = l_expr;
} else {
format(&l_expr, *((template_type *)STRALIGN("l_$ ")));
format(&a_expr, *((template_type *)STRALIGN("a_$ ")));
i_expr = l_expr;
if (level != 1)
codegen_error(*((error_string *)STRALIGN("String in composite type illegal for this target")));
}
append_index(&a_expr, level);
(void)fprintf((*where).fp, " "), Putl((*where), 0);
if (Member((unsigned)(omode), Conset[64]))
if (topack) {
gen_pack_type(&(*where), i_expr, simple_descriptor.A[(int)(integertok)], level + 2, false, topack, (*G129_check_subtypes));
} else {
(void)fprintf((*where).fp, "%*c", leftin(level), ' '), Putl((*where), 0);
write_exp(&(*where), &l_expr);
(void)fprintf((*where).fp, " := rpc_ch[m_index + 1];\n"), Putl((*where), 1);
(void)fprintf((*where).fp, "%*c", leftin(level), ' '), Putl((*where), 0);
(void)fprintf((*where).fp, "m_index := (m_index + 2);"), Putl((*where), 0);
}
else {
if ((omode == vaxpas))
gen_pack_type(&(*where), l_expr, simple_descriptor.A[(int)(shortok)], level + 2, false, topack, (*G129_check_subtypes));
else
gen_pack_type(&(*where), l_expr, simple_descriptor.A[(int)(integertok)], level + 2, false, topack, (*G129_check_subtypes));
}
(void)fprintf((*where).fp, "%*cFOR rpc_%c := 1 TO ", leftin(level), ' ', index_a), Putl((*where), 0);
write_exp(&(*where), &i_expr);
(void)fprintf((*where).fp, " DO BEGIN\n"), Putl((*where), 1);
gen_pack_type(&(*where), a_expr, simple_descriptor.A[(int)(chartok)], level + 2, false, topack, (*G129_check_subtypes));
(void)fprintf((*where).fp, "%*cEND {for \n", leftin(level), ' '), Putl((*where), 1);
write_exp(&(*where), &i_expr);
(void)fprintf((*where).fp, "};\n"), Putl((*where), 1);
}
size_so_far = (*G127_original_size) + W149->typ_max_size;
}
}
}
void
check_buffer_overflow(allowance)
integer allowance;
{
if ((*G125_check_size) && ((size_so_far + allowance) > non_fragmentation_limit))
if ((allowance <= fragmentation_threshold)) {
fragmentation_used = true;
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf((*G119_where).fp, "%*cif (rpc_p_buf->m_index > RPC_BUFFER_SIZE - %1d) (void)rpc_", leftin((*G121_level)) + 4, ' ', allowance), Putl((*G119_where), 0);
if ((*G123_topack))
(void)fprintf((*G119_where).fp, "put(&rpc_p_buf);\n"), Putl((*G119_where), 1);
else
(void)fprintf((*G119_where).fp, "get(&rpc_p_buf);\n"), Putl((*G119_where), 1);
} else {
(void)fprintf((*G119_where).fp, "%*cif (rpc_p_buf^.m_index > RPC_BUFFER_SIZE - %1d) then rpc_", leftin((*G121_level)) + 4, ' ', allowance), Putl((*G119_where), 0);
if ((*G123_topack))
(void)fprintf((*G119_where).fp, "put(rpc_p_buf);\n"), Putl((*G119_where), 1);
else
(void)fprintf((*G119_where).fp, "get(rpc_p_buf);\n"), Putl((*G119_where), 1);
}
}
}
void
gen_pack_type(where, expr, typ, level, deref, topack, check_size)
text *where;
expression expr;
ptr_defined_type typ;
integer level;
boolean deref;
boolean topack;
boolean check_size;
{
char ch;
ptr_named_type scan;
expression exp2;
expression l_expr, s_expr;
register integer i;
integer original_size;
boolean check_subtypes;
text *F120;
integer *F122;
boolean *F124;
boolean *F126;
integer *F128;
boolean *F130;
F130 = G129_check_subtypes;
G129_check_subtypes = &check_subtypes;
F128 = G127_original_size;
G127_original_size = &original_size;
F126 = G125_check_size;
G125_check_size = &check_size;
F124 = G123_topack;
G123_topack = &topack;
F122 = G121_level;
G121_level = &level;
F120 = G119_where;
G119_where = &(*where);
(*G127_original_size) = size_so_far;
ch = (unsigned)('a') + (*G121_level) - 1;
l_expr = expr;
prepend_1(&l_expr, '_');
s_expr = l_expr;
prepend_1(&l_expr, 'l');
prepend_1(&s_expr, 's');
{
register struct S75 *W150 = &(*typ);
if (W150->typ_external) {
(void)fprintf((*G119_where).fp, "%*c%.3s_", leftin((*G121_level)), ' ', upkpck.A[(int)((*G123_topack))].A), Putl((*G119_where), 0);
write_name(&op_file, &W150->typ_name->nty_name);
(void)fprintf((*G119_where).fp, "(rpc_p_buf,"), Putl((*G119_where), 0);
if ((Member((unsigned)(omode), cmode.S)) && !(*G123_topack))
Putchr('&', (*G119_where));
write_exp(&(*G119_where), &expr);
(void)fprintf((*G119_where).fp, ");\n"), Putl((*G119_where), 1);
} else {
(*G129_check_subtypes) = (boolean)((*G125_check_size) && (size_so_far + W150->typ_max_size > non_fragmentation_limit) && (W150->typ_max_size > fragmentation_threshold));
check_buffer_overflow(W150->typ_max_size);
switch ((int)(W150->typ_basic_type)) {
case chartok:
if ((Member((unsigned)(omode), cmode.S)) || (*G123_topack) || (expr.str.A[expr.len - 1] != ']')) {
(void)fprintf((*G119_where).fp, "%*c%.3s_char(rpc_p_buf, ", leftin((*G121_level)), ' ', upkpck.A[(int)((*G123_topack))].A), Putl((*G119_where), 0);
if (((*G121_level) == 1) && deref && (Member((unsigned)(omode), cmode.S)))
Putchr('*', (*G119_where));
write_exp(&(*G119_where), &expr);
(void)fprintf((*G119_where).fp, ");\n"), Putl((*G119_where), 1);
} else {
(void)fprintf((*G119_where).fp, "%*cBEGIN\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
(void)fprintf((*G119_where).fp, "%*c", leftin((*G121_level)) + 4, ' '), Putl((*G119_where), 0);
write_exp(&(*G119_where), &expr);
(void)fprintf((*G119_where).fp, ":=rpc_ch[m_index];\n"), Putl((*G119_where), 1);
(void)fprintf((*G119_where).fp, "%*cm_index := m_index+1;\n", leftin((*G121_level)) + 4, ' '), Putl((*G119_where), 1);
(void)fprintf((*G119_where).fp, "%*cEND;\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
}
size_so_far = size_so_far + 1;
break ;
case bytetok: case shortok: case integertok: case real32tok:
case real48tok: case real64tok: case real128tok: case longtok:
(void)fprintf((*G119_where).fp, "%*c%.3s", leftin((*G121_level)), ' ', upkpck.A[(int)((*G123_topack))].A), Putl((*G119_where), 0);
{
register struct S102 *W151 = &W150->typ_name->nty_name;
{
integer B152 = 4,
B153 = W151->len;
if (B152 <= B153)
for (i = B152; ; i++) {
Putchr(W151->str.A[i - 1], (*G119_where));
if (i == B153) break;
}
}
}
(void)fprintf((*G119_where).fp, "(rpc_p_buf, "), Putl((*G119_where), 0);
if (((*G121_level) == 1) && deref && (Member((unsigned)(omode), cmode.S)))
Putchr('*', (*G119_where));
write_exp(&(*G119_where), &expr);
(void)fprintf((*G119_where).fp, ");\n"), Putl((*G119_where), 1);
switch ((int)(W150->typ_basic_type)) {
case bytetok:
size_so_far = size_so_far + 1;
break ;
case shortok: case integertok:
size_so_far = size_so_far + 2;
break ;
case real32tok: case longtok:
size_so_far = size_so_far + 4;
break ;
case real48tok:
size_so_far = size_so_far + 6;
break ;
case real64tok:
size_so_far = size_so_far + 8;
break ;
case real128tok:
size_so_far = size_so_far + 16;
break ;
default:
Caseerror(Line);
}
break ;
case arraytok:
exp2 = expr;
append_index(&exp2, (*G121_level));
(void)fprintf((*G119_where).fp, "%*c", leftin((*G121_level)), ' '), Putl((*G119_where), 0);
if (!(Member((unsigned)(omode), cmode.S))) {
(void)fprintf((*G119_where).fp, "FOR rpc_%c := %1d TO %1d DO BEGIN\n", ch, W150->U.V4.typ_low, W150->U.V4.typ_high), Putl((*G119_where), 1);
} else {
(void)fprintf((*G119_where).fp, "for (rpc_%c = 0; rpc_%c<%1d; rpc_%c++) {\n", ch, ch, W150->U.V4.typ_high - W150->U.V4.typ_low + 1, ch), Putl((*G119_where), 1);
}
size_so_far = (*G127_original_size) + W150->typ_max_size;
gen_pack_type(&(*G119_where), exp2, W150->typ_subtype, (*G121_level) + 1, false, (*G123_topack), (*G129_check_subtypes));
size_so_far = (*G127_original_size) + W150->typ_max_size;
if (Member((unsigned)(omode), cmode.S))
(void)fprintf((*G119_where).fp, "%*c}\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
else
(void)fprintf((*G119_where).fp, "%*cEND {FOR};\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
break ;
case recordtok:
scan = W150->U.V5.typ_fields;
while (scan != (struct S76 *)NIL)
{
register struct S76 *W154 = &(*scan);
exp2 = expr;
if (((*G121_level) == 1) && deref && (Member((unsigned)(omode), cmode.S)))
format(&exp2, *((template_type *)STRALIGN("$-> ")));
else
format(&exp2, *((template_type *)STRALIGN("$. ")));
append_name(&exp2, W154->nty_name);
gen_pack_type(&(*G119_where), exp2, W154->nty_type, (*G121_level), false, (*G123_topack), (*G129_check_subtypes));
scan = W154->nty_next;
}
break ;
case accesstok:
if ((*G129_check_subtypes))
check_buffer_overflow(1);
size_so_far = size_so_far + 1;
if (Member((unsigned)(omode), cmode.S)) {
exp2 = expr;
format(&exp2, *((template_type *)STRALIGN("*($) ")));
if (!(*G123_topack)) {
(void)fprintf((*G119_where).fp, "%*c", leftin((*G121_level)), ' '), Putl((*G119_where), 0);
(void)fprintf((*G119_where).fp, "if (next_byte(rpc_p_buf)) {\n"), Putl((*G119_where), 1);
(void)fprintf((*G119_where).fp, "%*c", leftin((*G121_level) + 1), ' '), Putl((*G119_where), 0);
write_exp(&(*G119_where), &expr);
if (W150->typ_subtype->typ_name == (struct S76 *)NIL)
codegen_error(*((error_string *)STRALIGN("Pointer to unnamed type - cannot allocate space!")));
(void)fprintf((*G119_where).fp, " = ("), Putl((*G119_where), 0);
write_name(&(*G119_where), &W150->typ_subtype->typ_name->nty_name);
(void)fprintf((*G119_where).fp, "*) malloc(sizeof("), Putl((*G119_where), 0);
write_name(&(*G119_where), &W150->typ_subtype->typ_name->nty_name);
(void)fprintf((*G119_where).fp, "));\n"), Putl((*G119_where), 1);
} else {
(void)fprintf((*G119_where).fp, "%*cif (", leftin((*G121_level)), ' '), Putl((*G119_where), 0);
write_exp(&(*G119_where), &expr);
(void)fprintf((*G119_where).fp, "==NULL) pck_byte(0);\n"), Putl((*G119_where), 1);
(void)fprintf((*G119_where).fp, "%*celse {\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
(void)fprintf((*G119_where).fp, "%*cpck_byte(1);\n", leftin((*G121_level) + 1), ' '), Putl((*G119_where), 1);
}
gen_pack_type(&(*G119_where), exp2, W150->typ_subtype, (*G121_level), false, (*G123_topack), (*G129_check_subtypes));
(void)fprintf((*G119_where).fp, "%*c} /* end if */\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
} else {
exp2 = expr;
append_1(&exp2, '^');
if (!(*G123_topack)) {
(void)fprintf((*G119_where).fp, "m_index:=m_index+1;\n"), Putl((*G119_where), 1);
(void)fprintf((*G119_where).fp, "%*cif b[m_index-1]<>0 then begin\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
(void)fprintf((*G119_where).fp, "%*cnew(", leftin((*G121_level) + 1), ' '), Putl((*G119_where), 0);
write_exp(&(*G119_where), &expr);
(void)fprintf((*G119_where).fp, ");\n"), Putl((*G119_where), 1);
} else {
(void)fprintf((*G119_where).fp, "%*cif ", leftin((*G121_level)), ' '), Putl((*G119_where), 0);
write_exp(&(*G119_where), &expr);
(void)fprintf((*G119_where).fp, " = NIL then pck_byte(0)\n"), Putl((*G119_where), 1);
(void)fprintf((*G119_where).fp, "%*celse begin\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
(void)fprintf((*G119_where).fp, "%*cpck_byte(1);\n", leftin((*G121_level) + 1), ' '), Putl((*G119_where), 1);
}
gen_pack_type(&(*G119_where), exp2, W150->typ_subtype, (*G121_level), false, (*G123_topack), (*G129_check_subtypes));
(void)fprintf((*G119_where).fp, "%*cend {if};\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
}
break ;
case sequence:
if ((*G121_level) > 1)
codegen_error(*((error_string *)STRALIGN("SEQUENCE type not allowed within composite type.")));
gen_pack_type(&(*G119_where), l_expr, simple_descriptor.A[(int)(integertok)], (*G121_level), deref, (*G123_topack), (*G129_check_subtypes));
exp2 = expr;
format(&exp2, *((template_type *)STRALIGN("a_$ ")));
append_index(&exp2, (*G121_level));
(void)fprintf((*G119_where).fp, "%*c", leftin((*G121_level)), ' '), Putl((*G119_where), 0);
if (!(Member((unsigned)(omode), cmode.S))) {
(void)fprintf((*G119_where).fp, "FOR rpc_%c := 1 TO l_", ch), Putl((*G119_where), 0);
write_exp(&(*G119_where), &expr);
(void)fprintf((*G119_where).fp, " DO BEGIN\n"), Putl((*G119_where), 1);
} else {
(void)fprintf((*G119_where).fp, "for (rpc_%c = 0; rpc_%c< ", ch, ch), Putl((*G119_where), 0);
if (deref && (Member((unsigned)(omode), cmode.S)))
Putchr('*', (*G119_where));
write_exp(&(*G119_where), &l_expr);
(void)fprintf((*G119_where).fp, "; rpc_%c++) {\n", ch), Putl((*G119_where), 1);
}
size_so_far = (*G127_original_size) + W150->typ_max_size;
gen_pack_type(&(*G119_where), exp2, W150->typ_subtype, (*G121_level) + 1, false, (*G123_topack), (*G129_check_subtypes));
size_so_far = (*G127_original_size) + W150->typ_max_size;
if (Member((unsigned)(omode), cmode.S))
(void)fprintf((*G119_where).fp, "%*c }\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
else
(void)fprintf((*G119_where).fp, "%*cEND {FOR};\n", leftin((*G121_level)), ' '), Putl((*G119_where), 1);
break ;
case stringtok:
gen_pack_string(&(*G119_where), expr, typ, (*G121_level), (*G123_topack));
gen_align(&(*G119_where), 1);
break ;
case substring:
exp2 = s_expr;
gen_pack_type(&(*G119_where), exp2, simple_descriptor.A[(int)(integertok)], (*G121_level), deref, (*G123_topack), (*G129_check_subtypes));
gen_pack_type(&(*G119_where), l_expr, simple_descriptor.A[(int)(integertok)], (*G121_level), deref, (*G123_topack), (*G129_check_subtypes));
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf((*G119_where).fp, " for (rpc_%c = ", ch), Putl((*G119_where), 0);
if (deref)
Putchr('*', (*G119_where));
write_exp(&(*G119_where), &s_expr);
(void)fprintf((*G119_where).fp, "-1; rpc_%c < ", ch), Putl((*G119_where), 0);
if (deref)
Putchr('*', (*G119_where));
write_exp(&(*G119_where), &l_expr);
(void)fprintf((*G119_where).fp, " + "), Putl((*G119_where), 0);
if (deref)
Putchr('*', (*G119_where));
write_exp(&(*G119_where), &s_expr);
(void)fprintf((*G119_where).fp, "-1; rpc_%c++) {\n", ch), Putl((*G119_where), 1);
} else {
(void)fprintf((*G119_where).fp, " FOR rpc_%c := ", ch), Putl((*G119_where), 0);
write_exp(&(*G119_where), &s_expr);
(void)fprintf((*G119_where).fp, " TO "), Putl((*G119_where), 0);
write_exp(&(*G119_where), &l_expr);
Putchr('+', (*G119_where));
write_exp(&(*G119_where), &s_expr);
(void)fprintf((*G119_where).fp, " - 1 DO BEGIN\n"), Putl((*G119_where), 1);
}
exp2 = expr;
prepend_1(&exp2, '_');
prepend_1(&exp2, 'a');
append_index(&exp2, (*G121_level));
size_so_far = (*G127_original_size) + W150->typ_max_size;
gen_pack_type(&(*G119_where), exp2, simple_descriptor.A[(int)(chartok)], (*G121_level) + 1, false, (*G123_topack), (*G129_check_subtypes));
size_so_far = (*G127_original_size) + W150->typ_max_size;
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf((*G119_where).fp, " }\n"), Putl((*G119_where), 1);
} else {
(void)fprintf((*G119_where).fp, " END;\n"), Putl((*G119_where), 1);
}
gen_align(&(*G119_where), 1);
break ;
default:
Caseerror(Line);
}
}
}
G119_where = F120;
G121_level = F122;
G123_topack = F124;
G125_check_size = F126;
G127_original_size = F128;
G129_check_subtypes = F130;
}
void
gen_pack(where, head, dirn, topack)
text *where;
ptr_idlist head;
attr_type dirn;
boolean topack;
{
expression expr;
do {
{
register struct S77 *W155 = &(*head);
register struct S75 *W156 = &(*W155->id_type);
expr.len = 0;
append_name(&expr, head->name);
if ((!client) && (!topack) && (omode == vaxvms))
if (contains(W155->id_type, *((set_of_token *)SETALIGN(Conset[65]))))
gen_allocate(&(*where), expr, W155->id_type, 1, true, *((set_of_token *)SETALIGN(Conset[66])));
if ((W155->attr == inoutok) || (W155->attr == dirn)) {
deref = (boolean)(client && !(runoptions.A[(int)(byvalue)].value && (W155->attr == intok)));
gen_pack_type(&(*where), expr, W155->id_type, 1, deref, topack, true);
}
if ((!client) && topack)
if (omode == vaxvms) {
if (contains(W155->id_type, *((set_of_token *)SETALIGN(Conset[67]))))
gen_allocate(&(*where), expr, W155->id_type, 1, false, *((set_of_token *)SETALIGN(Conset[68])));
} else {
if (contains(W155->id_type, *((set_of_token *)SETALIGN(Conset[69]))))
gen_allocate(&(*where), expr, W155->id_type, 1, false, *((set_of_token *)SETALIGN(Conset[70])));
}
if (client && (W155->attr == inoutok) && topack)
if (contains(W155->id_type, *((set_of_token *)SETALIGN(Conset[71]))))
gen_allocate(&(*where), expr, W155->id_type, 1, false, *((set_of_token *)SETALIGN(Conset[72])));
}
head = head->next;
} while (!(head == (struct S77 *)NIL));
}
void gen_header();
void
gen_formals_c(head)
ptr_idlist head;
{
integer a;
ptr_idlist scan;
a = 0;
scan = head;
Putchr('(', (*G131_where));
while (scan != (struct S77 *)NIL) {
if (Member((unsigned)(scan->id_type->typ_basic_type), Conset[73]))
(void)fprintf((*G131_where).fp, "a_"), Putl((*G131_where), 0);
write_name(&(*G131_where), &scan->name);
if (scan->id_type->typ_basic_type == substring) {
(void)fprintf((*G131_where).fp, ", s_"), Putl((*G131_where), 0);
write_name(&(*G131_where), &scan->name);
a = a + 1;
}
if (Member((unsigned)(scan->id_type->typ_basic_type), Conset[74])) {
(void)fprintf((*G131_where).fp, ", l_"), Putl((*G131_where), 0);
write_name(&(*G131_where), &scan->name);
a = a + 1;
}
scan = scan->next;
if (scan != (struct S77 *)NIL) {
(void)fprintf((*G131_where).fp, ", "), Putl((*G131_where), 0);
a = a + 1;
if (a > 3) {
a = 0;
Putchr('\n', (*G131_where));
(void)fprintf((*G131_where).fp, " "), Putl((*G131_where), 0);
}
}
}
Putchr(')', (*G131_where)),Putchr('\n', (*G131_where));
}
void
gen_params(head)
ptr_idlist head;
{
integer a;
ptr_idlist scan;
char ch;
boolean simple_ref;
boolean array_deref;
scan = head;
do {
(void)fprintf((*G131_where).fp, " "), Putl((*G131_where), 0);
array_deref = (boolean)((client || (*G133_doing_externals)) && !(Member((unsigned)(omode), cmode.S)));
simple_ref = (boolean)((client || (*G133_doing_externals)) && !((runoptions.A[(int)(byvalue)].value) && (scan->attr == intok)));
{
register struct S75 *W157 = &(*scan->id_type);
switch ((int)(W157->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:
write_declaration(&(*G131_where), ' ', scan, simple_ref);
break ;
case arraytok:
write_declaration(&(*G131_where), ' ', scan, array_deref);
break ;
case stringtok:
if (!(Member((unsigned)(omode), (Union(cmode.S, Conset[75]))))) {
write_declaration(&(*G131_where), 'a', scan, array_deref);
Putchr(';', (*G131_where)),Putchr('\n', (*G131_where));
write_integer(&(*G131_where), 'l', &scan->name, simple_ref);
} else {
write_declaration(&(*G131_where), ' ', scan, array_deref);
}
Claimset();
break ;
case sequence:
write_declaration(&(*G131_where), 'a', scan, array_deref);
Putchr(';', (*G131_where)),Putchr('\n', (*G131_where));
write_integer(&(*G131_where), 'l', &scan->name, simple_ref);
break ;
case substring:
write_declaration(&(*G131_where), 'a', scan, array_deref);
Putchr(';', (*G131_where)),Putchr('\n', (*G131_where));
write_integer(&(*G131_where), 's', &scan->name, simple_ref);
Putchr(';', (*G131_where)),Putchr('\n', (*G131_where));
write_integer(&(*G131_where), 'l', &scan->name, simple_ref);
break ;
default:
Caseerror(Line);
}
}
scan = scan->next;
if (scan != (struct S77 *)NIL)
Putchr(';', (*G131_where)),Putchr('\n', (*G131_where));
} while (!(scan == (struct S77 *)NIL));
}
void
gen_header(where, ptr, doing_externals, parameters_wanted)
text *where;
ptr_block_table ptr;
boolean doing_externals, parameters_wanted;
{
text *F132;
boolean *F134;
F134 = G133_doing_externals;
G133_doing_externals = &doing_externals;
F132 = G131_where;
G131_where = &(*where);
{
register struct S78 *W158 = &(*ptr);
if (Member((unsigned)(omode), cmode.S)) {
if (client) {
if (W158->b_type == functok) {
writok(&(*G131_where), W158->C33_return);
Putchr(' ', (*G131_where));
}
write_name(&(*G131_where), &W158->name);
gen_formals_c(W158->list);
} else {
if (!(*G133_doing_externals))
(void)fprintf((*G131_where).fp, "r_"), Putl((*G131_where), 0);
write_name(&(*G131_where), &W158->name);
(void)fprintf((*G131_where).fp, "()"), Putl((*G131_where), 0);
if ((*G133_doing_externals)) {
Putchr(';', (*G131_where)),Putchr('\n', (*G131_where));
(void)fprintf((*G131_where).fp, "/* Parameters: "), Putl((*G131_where), 0);
if (W158->list == (struct S77 *)NIL)
(void)fprintf((*G131_where).fp, "none"), Putl((*G131_where), 0);
}
Putchr('\n', (*G131_where));
if (!(*G133_doing_externals))
Putchr('{', (*G131_where)),Putchr('\n', (*G131_where));
}
} else {
if ((client || (*G133_doing_externals))) {
writok(&(*G131_where), W158->b_type);
write_name(&(*G131_where), &W158->name);
} else {
writok(&(*G131_where), proctok);
if (!(*G133_doing_externals))
(void)fprintf((*G131_where).fp, "r_"), Putl((*G131_where), 0);
write_name(&(*G131_where), &W158->name);
if (!(*G133_doing_externals))
Putchr(';', (*G131_where)),Putchr('\n', (*G131_where));
}
}
if (parameters_wanted)
if ((W158->list != (struct S77 *)NIL)) {
if (!(Member((unsigned)(omode), cmode.S)))
if (client || (*G133_doing_externals))
Putchr('(', (*G131_where)),Putchr('\n', (*G131_where));
else
(void)fprintf((*G131_where).fp, "VAR\n"), Putl((*G131_where), 1);
gen_params(W158->list);
if ((client || (*G133_doing_externals)) && !(Member((unsigned)(omode), cmode.S)))
Putchr(')', (*G131_where));
}
if (!(Member((unsigned)(omode), cmode.S))) {
if ((client || (*G133_doing_externals))) {
if (parameters_wanted && (W158->b_type == functok)) {
(void)fprintf((*G131_where).fp, ": "), Putl((*G131_where), 0);
writok(&(*G131_where), W158->C33_return);
}
}
}
if (((client || (*G133_doing_externals)) && !(Member((unsigned)(omode), cmode.S))) || (W158->list != (struct S77 *)NIL))
Putchr(';', (*G131_where)),Putchr('\n', (*G131_where));
}
G131_where = F132;
G133_doing_externals = F134;
}
void
generate_externals()
{
ptr_block_table scan;
scan = blockptr;
while (scan != (struct S78 *)NIL) {
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf(op_file.fp, "extern "), Putl(op_file, 0);
if (scan->b_type == functok) {
writok(&op_file, scan->C33_return);
Putchr(' ', op_file);
}
gen_header(&op_file, scan, true, true);
(void)fprintf(op_file.fp, " */\n"), Putl(op_file, 1);
} else {
gen_header(&op_file, scan, true, true);
if (omode == m6809)
(void)fprintf(op_file.fp, "EXTERNAL;\n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, "EXTERN;\n"), Putl(op_file, 1);
}
Putchr('\n', op_file);
scan = scan->next;
}
}
void
gen_type_decl_c(where, expr, pt, level)
text *where;
expression expr;
ptr_defined_type pt;
integer level;
{
ptr_named_type scan;
expression exp2;
{
register struct S75 *W159 = &(*pt);
switch ((int)(W159->typ_basic_type)) {
case chartok: case bytetok: case shortok: case integertok:
case real32tok: case real48tok: case real64tok: case real128tok:
case longtok:
(void)fprintf((*where).fp, "%*c", leftin(level), ' '), Putl((*where), 0);
write_name(&(*where), &simple_descriptor.A[(int)(W159->typ_basic_type)]->typ_name->nty_name);
Putchr(' ', (*where));
write_exp(&(*where), &expr);
break ;
case substring: case stringtok:
(void)fprintf((*where).fp, "%*c", leftin(level), ' '), Putl((*where), 0);
(void)fprintf((*where).fp, "rpc_char "), Putl((*where), 0);
write_exp(&(*where), &expr);
(void)fprintf((*where).fp, "[%1d]", (W159->U.V4.typ_high + 1)), Putl((*where), 0);
break ;
case arraytok:
exp2 = expr;
append_1(&exp2, '[');
append_decimal(&exp2, W159->U.V4.typ_high - W159->U.V4.typ_low + 1);
append_1(&exp2, ']');
gen_type_decl_c(&(*where), exp2, W159->typ_subtype, level);
break ;
case sequence:
exp2 = expr;
append_1(&exp2, '[');
append_decimal(&exp2, W159->U.V4.typ_high - W159->U.V4.typ_low + 1);
append_1(&exp2, ']');
gen_type_decl_c(&(*where), exp2, W159->typ_subtype, level);
break ;
case accesstok:
exp2 = expr;
prepend_1(&exp2, '(');
prepend_1(&exp2, '*');
append_1(&exp2, ')');
gen_type_decl_c(&(*where), exp2, W159->typ_subtype, level);
break ;
case recordtok:
(void)fprintf((*where).fp, "%*cstruct {\n", leftin(level), ' '), Putl((*where), 1);
scan = W159->U.V5.typ_fields;
while (scan != (struct S76 *)NIL) {
exp2.len = 0;
append_name(&exp2, scan->nty_name);
gen_type_decl_c(&(*where), exp2, scan->nty_type, level + 1);
Putchr(';', (*where)),Putchr('\n', (*where));
scan = scan->nty_next;
}
(void)fprintf((*where).fp, "%*c} ", leftin(level), ' '), Putl((*where), 0);
write_exp(&(*where), &expr);
break ;
default:
Caseerror(Line);
}
}
}
void
gen_type_pas(where, pt, level)
text *where;
ptr_defined_type pt;
integer level;
{
ptr_named_type scan;
expression exp2;
{
register struct S75 *W160 = &(*pt);
if ((level > 1) && (W160->typ_name != (struct S76 *)NIL)) {
write_name(&(*where), &W160->typ_name->nty_name);
} else
switch ((int)(W160->typ_basic_type)) {
case chartok: case bytetok: case shortok: case integertok:
case real32tok: case real48tok: case real64tok: case real128tok:
case longtok:
write_name(&(*where), &simple_descriptor.A[(int)(W160->typ_basic_type)]->typ_name->nty_name);
break ;
case substring: case stringtok:
if ((omode == vaxvms) && (W160->typ_basic_type == stringtok)) {
(void)fprintf((*where).fp, "RECORD strlen: rpc_short;\n"), Putl((*where), 1);
(void)fprintf((*where).fp, "%*cDType, Cont: rpc_byte;\n", leftin(level) + 8, ' '), Putl((*where), 1);
(void)fprintf((*where).fp, "%*cStrAdr: ^t_", leftin(level) + 8, ' '), Putl((*where), 0);
write_name(&(*where), &W160->typ_name->nty_name);
Putchr('\n', (*where));
(void)fprintf((*where).fp, "%*cEND", leftin(level) + 4, ' '), Putl((*where), 0);
} else
if ((omode == vaxpas) && (W160->typ_basic_type == stringtok)) {
(void)fprintf((*where).fp, "VARYING[%1d] OF CHAR", W160->U.V4.typ_high), Putl((*where), 0);
} else
if ((Member((unsigned)(omode), Conset[76])) && (W160->typ_basic_type == stringtok)) {
(void)fprintf((*where).fp, "STRING[%1d]", W160->U.V4.typ_high), Putl((*where), 0);
} else {
(void)fprintf((*where).fp, "PACKED ARRAY [1..%1d] OF CHAR", W160->U.V4.typ_high), Putl((*where), 0);
}
break ;
case arraytok:
(void)fprintf((*where).fp, "ARRAY [%1d..%1d] OF ", W160->U.V4.typ_low, W160->U.V4.typ_high), Putl((*where), 0);
gen_type_pas(&(*where), W160->typ_subtype, level + 1);
break ;
case sequence:
(void)fprintf((*where).fp, "ARRAY [1..%1d] OF ", W160->U.V4.typ_high), Putl((*where), 0);
gen_type_pas(&(*where), W160->typ_subtype, level + 1);
break ;
case accesstok:
Putchr('^', (*where));
gen_type_pas(&(*where), W160->typ_subtype, level + 1);
break ;
case recordtok:
(void)fprintf((*where).fp, "RECORD\n"), Putl((*where), 1);
scan = W160->U.V5.typ_fields;
while (scan != (struct S76 *)NIL) {
exp2.len = 0;
(void)fprintf((*where).fp, "%*c", (leftin(level) + 4), ' '), Putl((*where), 0);
write_name(&(*where), &scan->nty_name);
(void)fprintf((*where).fp, ": "), Putl((*where), 0);
gen_type_pas(&(*where), scan->nty_type, level + 1);
Putchr(';', (*where)),Putchr('\n', (*where));
scan = scan->nty_next;
}
(void)fprintf((*where).fp, "%*cEND {RECORD}", leftin(level), ' '), Putl((*where), 0);
break ;
default:
Caseerror(Line);
}
}
}
void
generate_types(where)
text *where;
{
ptr_named_type scan;
expression expr;
scan = typeptr;
while (scan != (struct S76 *)NIL)
{
register struct S76 *W161 = &(*scan);
if (omode == vaxvms)
if ((W161->nty_type->typ_basic_type == stringtok)) {
(void)fprintf((*where).fp, "t_"), Putl((*where), 0);
write_name(&(*where), &W161->nty_name);
(void)fprintf((*where).fp, " = "), Putl((*where), 0);
(void)fprintf((*where).fp, "PACKED ARRAY [1..%1d] OF CHAR;\n", W161->nty_type->U.V4.typ_high), Putl((*where), 1);
}
expr.len = 0;
append_name(&expr, W161->nty_name);
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf((*where).fp, "typedef "), Putl((*where), 0);
gen_type_decl_c(&(*where), expr, W161->nty_type, 1);
} else {
write_name(&(*where), &W161->nty_name);
(void)fprintf((*where).fp, " = "), Putl((*where), 0);
gen_type_pas(&(*where), W161->nty_type, 1);
}
Putchr(';', (*where)),Putchr('\n', (*where));
scan = W161->nty_next;
}
Putchr('\n', (*where));
}
void
ext_generator(ext_mode, ext_name)
output_mode ext_mode;
astring ext_name;
{
if (!(Member((unsigned)(omode), Conset[77])))
if (file_open(&op_file, &ext_name, rewriting)) {
client = false;
omode = ext_mode;
Putchr('\n', op_file);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "/* "), Putl(op_file, 0);
else
(void)fprintf(op_file.fp, "{* "), Putl(op_file, 0);
(void)fprintf(op_file.fp, "Stub Version Number: "), Putl(op_file, 0);
if (version_num == 0)
(void)fprintf(op_file.fp, "zero (no check)"), Putl(op_file, 0);
else
(void)fprintf(op_file.fp, "%1d", version_num), Putl(op_file, 0);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, " */\n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, " *}\n"), Putl(op_file, 1);
Putchr('\n', op_file);
if ((runoptions.A[(int)(types)].value) && (typeptr != (struct S76 *)NIL)) {
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, "TYPE\n"), Putl(op_file, 1);
generate_types(&op_file);
}
generate_externals();
if (!(file_close(&op_file)))
error(cant_cls_ext);
} else
error(cant_opn_ext);
}
void gen_module();
void
do_include(which)
opt_name which;
{
register integer i;
(void)fprintf((*G135_where).fp, "*INCLUDE rpc"), Putl((*G135_where), 0);
{
integer B162 = 1,
B163 = 10;
if (B162 <= B163)
for (i = B162; ; i++) {
if (which.A[i - 1] != ' ')
Putchr(which.A[i - 1], (*G135_where));
if (i == B163) break;
}
}
Putchr('\n', (*G135_where));
}
void
gen_module(where)
text *where;
{
text *F136;
F136 = G135_where;
G135_where = &(*where);
Putchr('\n', (*G135_where));
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf((*G135_where).fp, "#include <rpcrts.h>\n"), Putl((*G135_where), 1);
Putchr('\n', (*G135_where));
} else {
if (!(Member((unsigned)(omode), Conset[78]))) {
(void)fprintf((*G135_where).fp, "MODULE "), Putl((*G135_where), 0);
if (client)
(void)fprintf((*G135_where).fp, "CLI"), Putl((*G135_where), 0);
else
(void)fprintf((*G135_where).fp, "SER"), Putl((*G135_where), 0);
write_name(&(*G135_where), &unitname);
Putchr(';', (*G135_where)),Putchr('\n', (*G135_where));
}
if ((Member((unsigned)(omode), Conset[79]))) {
(void)fprintf((*G135_where).fp, "UNIT "), Putl((*G135_where), 0);
if (client)
(void)fprintf((*G135_where).fp, "CLI"), Putl((*G135_where), 0);
else
(void)fprintf((*G135_where).fp, "SER"), Putl((*G135_where), 0);
write_name(&(*G135_where), &unitname);
if ((omode == macturbo))
(void)fprintf((*G135_where).fp, "(5)"), Putl((*G135_where), 0);
Putchr(';', (*G135_where)),Putchr('\n', (*G135_where));
(void)fprintf((*G135_where).fp, "INTERFACE\n"), Putl((*G135_where), 1);
if ((omode == pcturbo)) {
(void)fprintf((*G135_where).fp, "USES rpcpcpas,\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " rpcstub,\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " tsturbo,\n"), Putl((*G135_where), 1);
if (external_marshalling)
(void)fprintf((*G135_where).fp, " extmarsh,\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " rpcrts"), Putl((*G135_where), 0);
} else {
(void)fprintf((*G135_where).fp, "{$U RPCMacPas}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{$U RPCStub}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{$U TSTurbo}\n"), Putl((*G135_where), 1);
if (external_marshalling)
(void)fprintf((*G135_where).fp, "{$U extmarsh}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{$U RPCRTS}\n"), Putl((*G135_where), 1);
if (!client) {
(void)fprintf((*G135_where).fp, "{--> It is assumed, by default, that the name of the unit library file <--}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{--> containing the server routines is the same as the package name. <--}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{--> If the assumption is wrong, just replace the following line. <--}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{$U "), Putl((*G135_where), 0);
write_name(&(*G135_where), &unitname);
Putchr('}', (*G135_where)),Putchr('\n', (*G135_where));
}
Putchr('\n', (*G135_where));
(void)fprintf((*G135_where).fp, "USES MemTypes,\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " QuickDraw,\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " OSIntf,\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " ToolIntf,\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " RPCMacPas,\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " RPCStub,\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " TSTurbo,\n"), Putl((*G135_where), 1);
if (external_marshalling)
(void)fprintf((*G135_where).fp, " extmarsh,\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " RPCRTS"), Putl((*G135_where), 0);
}
if (!client) {
Putchr(',', (*G135_where)),Putchr('\n', (*G135_where));
(void)fprintf((*G135_where).fp, "{--> It is assumed, by default, that the name of the unit containing <--}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{--> the server routines is the same as the package name. If the <--}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{--> assumption is wrong, just replace the following line. <--}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " "), Putl((*G135_where), 0);
write_name(&(*G135_where), &unitname);
}
Putchr(';', (*G135_where)),Putchr('\n', (*G135_where));
Putchr('\n', (*G135_where));
if ((!client) && (typeptr != (struct S76 *)NIL)) {
(void)fprintf((*G135_where).fp, "{--> Being this a server stub, the TYPE declarations should not be <--}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{--> included here (they belong to the unit containing the server <--}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{--> routines). However you will find them below (commented out), in <--}\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, "{--> case you need them for reference. <--}\n"), Putl((*G135_where), 1);
Putchr('{', (*G135_where)),Putchr('\n', (*G135_where));
}
if ((typeptr != (struct S76 *)NIL))
(void)fprintf((*G135_where).fp, "TYPE\n"), Putl((*G135_where), 1);
} else {
Putchr('\n', (*G135_where));
(void)fprintf((*G135_where).fp, "CONST\n"), Putl((*G135_where), 1);
do_include(*((opt_name *)STRALIGN("const.h ")));
Putchr('\n', (*G135_where));
(void)fprintf((*G135_where).fp, "TYPE\n"), Putl((*G135_where), 1);
do_include(*((opt_name *)STRALIGN("types.h ")));
}
}
generate_types(&(*G135_where));
if ((!client) && (Member((unsigned)(omode), Conset[80])) && (typeptr != (struct S76 *)NIL))
Putchr('}', (*G135_where)),Putchr('\n', (*G135_where));
if (client) {
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf((*G135_where).fp, "rpc_handle h_"), Putl((*G135_where), 0);
write_name(&(*G135_where), &unitname);
Putchr(';', (*G135_where)),Putchr('\n', (*G135_where));
} else {
if ((omode == cerncross))
(void)fprintf((*G135_where).fp, "EXPORT\n"), Putl((*G135_where), 1);
else
(void)fprintf((*G135_where).fp, "VAR\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " h_"), Putl((*G135_where), 0);
write_name(&(*G135_where), &unitname);
if ((Member((unsigned)(omode), Conset[81])))
(void)fprintf((*G135_where).fp, ": [global] integer;\n"), Putl((*G135_where), 1);
else
if ((omode == m6809))
(void)fprintf((*G135_where).fp, ": integer external;\n"), Putl((*G135_where), 1);
else
if ((Member((unsigned)(omode), Conset[82])))
(void)fprintf((*G135_where).fp, ": client_pointer;\n"), Putl((*G135_where), 1);
else
(void)fprintf((*G135_where).fp, ": integer;\n"), Putl((*G135_where), 1);
}
} else {
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf((*G135_where).fp, "program_index p_"), Putl((*G135_where), 0);
write_name(&(*G135_where), &unitname);
Putchr(';', (*G135_where)),Putchr('\n', (*G135_where));
} else {
if ((omode == cerncross))
(void)fprintf((*G135_where).fp, "EXPORT\n"), Putl((*G135_where), 1);
else
(void)fprintf((*G135_where).fp, "VAR\n"), Putl((*G135_where), 1);
(void)fprintf((*G135_where).fp, " p_"), Putl((*G135_where), 0);
write_name(&(*G135_where), &unitname);
if ((Member((unsigned)(omode), Conset[83])))
(void)fprintf((*G135_where).fp, ": [global] integer;\n"), Putl((*G135_where), 1);
else
if ((Member((unsigned)(omode), Conset[84])))
(void)fprintf((*G135_where).fp, ": program_pointer;\n"), Putl((*G135_where), 1);
else
(void)fprintf((*G135_where).fp, ": program_index;\n"), Putl((*G135_where), 1);
}
}
Putchr('\n', (*G135_where));
if (!(Member((unsigned)(omode), Union(cmode.S, Conset[85])))) {
do_include(*((opt_name *)STRALIGN("proc.h ")));
do_include(*((opt_name *)STRALIGN("stub.h ")));
Putchr('\n', (*G135_where));
}
Claimset();
if (external_marshalling)
if ((Member((unsigned)(omode), Union(cmode.S, Conset[86]))))
decl_ext_marshal();
Claimset();
if ((!client) && (!(Member((unsigned)(omode), Conset[87]))))
generate_externals();
G135_where = F136;
}
void client_generator();
void
gen_client_block_pas(ptr)
ptr_block_table ptr;
{
register integer a;
expression return_value;
if (Member((unsigned)(omode), Conset[88]))
(void)fprintf(op_file.fp, "[GLOBAL]\n"), Putl(op_file, 1);
size_so_far = 0;
gen_header(&op_file, ptr, false, (boolean)(!(omode == macturbo)));
if (omode == m6809)
(void)fprintf(op_file.fp, " ENTRY;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "VAR rpc_p_buf: rpc_message_pointer;\n"), Putl(op_file, 1);
{
integer B164 = 1,
B165 = ptr->blk_nesting;
if (B164 <= B165)
for (a = B164; ; a++) {
(void)fprintf(op_file.fp, " rpc_%c : rpc_integer;\n", (unsigned)('a') - 1 + a), Putl(op_file, 1);
if (a == B165) break;
}
}
if (ptr->b_type == functok) {
(void)fprintf(op_file.fp, " rpc_ret : "), Putl(op_file, 0);
writok(&op_file, ptr->C33_return);
Putchr(';', op_file),Putchr('\n', op_file);
}
(void)fprintf(op_file.fp, "BEGIN\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " rpc_begin(rpc_p_buf, h_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ", {vers=}%1d, {proc=}%1d);\n", version_num, (*G137_proc_number)), Putl(op_file, 1);
(void)fprintf(op_file.fp, " WITH rpc_p_buf^ DO BEGIN\n"), Putl(op_file, 1);
if (ptr->list != (struct S77 *)NIL)
gen_pack(&op_file, ptr->list, intok, true);
(void)fprintf(op_file.fp, " END {WITH};\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (ptr->blk_status_param != (struct S77 *)NIL) {
write_name(&op_file, &ptr->blk_status_param->name);
(void)fprintf(op_file.fp, " := "), Putl(op_file, 0);
}
if (ptr->blk_cast)
(void)fprintf(op_file.fp, "rpc_cast"), Putl(op_file, 0);
else
(void)fprintf(op_file.fp, "rpc_call"), Putl(op_file, 0);
if (ptr->blk_status_param != (struct S77 *)NIL)
(void)fprintf(op_file.fp, "_status"), Putl(op_file, 0);
(void)fprintf(op_file.fp, "(h_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ", rpc_p_buf"), Putl(op_file, 0);
if (!ptr->blk_cast)
(void)fprintf(op_file.fp, ",%1d", ptr->blk_timeout), Putl(op_file, 0);
(void)fprintf(op_file.fp, ");\n"), Putl(op_file, 1);
if (ptr->blk_status_param != (struct S77 *)NIL) {
(void)fprintf(op_file.fp, " IF odd("), Putl(op_file, 0);
write_name(&op_file, &ptr->blk_status_param->name);
(void)fprintf(op_file.fp, ") THEN "), Putl(op_file, 0);
}
(void)fprintf(op_file.fp, " WITH rpc_p_buf^ DO BEGIN\n"), Putl(op_file, 1);
size_so_far = 0;
if (ptr->blk_max_out > 0) {
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, " rpc_p_buf->m_index ="), Putl(op_file, 0);
else
(void)fprintf(op_file.fp, " m_index :="), Putl(op_file, 0);
(void)fprintf(op_file.fp, " RETURN_HEADER_LENGTH;\n"), Putl(op_file, 1);
}
if (ptr->b_type == functok) {
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
dopack_simple(&op_file, ptr->C33_return, false);
(void)fprintf(op_file.fp, "rpc_ret);\n"), Putl(op_file, 1);
}
if (ptr->list != (struct S77 *)NIL)
gen_pack(&op_file, ptr->list, outok, false);
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf(op_file.fp, " c_dispose(rpc_p_buf);\n"), Putl(op_file, 1);
if (ptr->b_type == functok)
(void)fprintf(op_file.fp, " return(rpc_ret);\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " }\n"), Putl(op_file, 1);
} else {
if (ptr->b_type == functok) {
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
write_name(&op_file, &ptr->name);
(void)fprintf(op_file.fp, " := rpc_ret;\n"), Putl(op_file, 1);
}
(void)fprintf(op_file.fp, " END {WITH};\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " rpc_dispose(rpc_p_buf);\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "END;\n"), Putl(op_file, 1);
}
Putchr('\n', op_file);
}
void
gen_client_block_c(ptr)
ptr_block_table ptr;
{
register integer a;
expression return_value;
size_so_far = 0;
gen_header(&op_file, ptr, false, true);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "{ rpc_message *rpc_p_buf;\n"), Putl(op_file, 1);
{
integer B166 = 1,
B167 = ptr->blk_nesting;
if (B166 <= B167)
for (a = B166; ; a++) {
(void)fprintf(op_file.fp, " register rpc_integer rpc_%c;\n", (unsigned)('a') - 1 + a), Putl(op_file, 1);
if (a == B167) break;
}
}
if (ptr->b_type == functok) {
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
writok(&op_file, ptr->C33_return);
(void)fprintf(op_file.fp, " rpc_ret;\n"), Putl(op_file, 1);
}
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
(void)fprintf(op_file.fp, "c_begin(rpc_p_buf, h_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ", /*vers=*/%1d, /*proc=*/%1d);\n", version_num, (*G137_proc_number)), Putl(op_file, 1);
if (ptr->list != (struct S77 *)NIL)
gen_pack(&op_file, ptr->list, intok, true);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (ptr->blk_status_param != (struct S77 *)NIL) {
Putchr('*', op_file);
write_name(&op_file, &ptr->blk_status_param->name);
(void)fprintf(op_file.fp, " = "), Putl(op_file, 0);
}
(void)fprintf(op_file.fp, "c_call"), Putl(op_file, 0);
if (ptr->blk_status_param != (struct S77 *)NIL)
(void)fprintf(op_file.fp, "_status"), Putl(op_file, 0);
(void)fprintf(op_file.fp, "(h_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ", rpc_p_buf, %1d);\n", ptr->blk_timeout), Putl(op_file, 1);
if (ptr->blk_status_param != (struct S77 *)NIL) {
(void)fprintf(op_file.fp, " if (*"), Putl(op_file, 0);
write_name(&op_file, &ptr->blk_status_param->name);
(void)fprintf(op_file.fp, " & 1) { /* If good call */ \n"), Putl(op_file, 1);
}
size_so_far = 0;
if (ptr->blk_max_out > 0)
(void)fprintf(op_file.fp, " rpc_p_buf->m_index = RETURN_HEADER_LENGTH;\n"), Putl(op_file, 1);
if (ptr->b_type == functok) {
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
dopack_simple(&op_file, ptr->C33_return, false);
(void)fprintf(op_file.fp, "rpc_ret);\n"), Putl(op_file, 1);
}
if (ptr->list != (struct S77 *)NIL)
gen_pack(&op_file, ptr->list, outok, false);
if (ptr->blk_status_param != (struct S77 *)NIL)
(void)fprintf(op_file.fp, " } /* end if good call */\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " c_dispose(rpc_p_buf);\n"), Putl(op_file, 1);
if (ptr->b_type == functok)
(void)fprintf(op_file.fp, " return(rpc_ret);\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " }\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
void
P71_gen_open()
{
if (Member((unsigned)(omode), Conset[89]))
if (runoptions.A[(int)(noautoinit)].value)
(void)fprintf(op_file.fp, "[GLOBAL]\n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, "[GLOBAL, INITIALIZE]\n"), Putl(op_file, 1);
writok(&op_file, proctok);
(void)fprintf(op_file.fp, "open_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "()\n"), Putl(op_file, 1);
else
Putchr(';', op_file),Putchr('\n', op_file);
if (omode == m6809)
(void)fprintf(op_file.fp, " ENTRY;\n"), Putl(op_file, 1);
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf(op_file.fp, "{ rpc_status status;\n"), Putl(op_file, 1);
} else {
(void)fprintf(op_file.fp, "VAR\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " status : rpc_status;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " service : rpc_name;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "BEGIN\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " service := "), Putl(op_file, 0);
write_name_padded(&op_file, unitname, '\'');
Putchr(';', op_file),Putchr('\n', op_file);
}
if (Member((unsigned)(omode), cmode.S))
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, "rp"), Putl(op_file, 0);
(void)fprintf(op_file.fp, "c_open(status, h_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ", "), Putl(op_file, 0);
if (Member((unsigned)(omode), cmode.S))
write_name_padded(&op_file, unitname, '"');
else
(void)fprintf(op_file.fp, "service"), Putl(op_file, 0);
(void)fprintf(op_file.fp, ");\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, "rp"), Putl(op_file, 0);
(void)fprintf(op_file.fp, "c_report_error(status);\n"), Putl(op_file, 1);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, " }\n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, "END;\n"), Putl(op_file, 1);
}
void
P72_gen_close()
{
if (Member((unsigned)(omode), Conset[90]))
(void)fprintf(op_file.fp, "[GLOBAL]\n"), Putl(op_file, 1);
writok(&op_file, proctok);
(void)fprintf(op_file.fp, "close_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "()\n"), Putl(op_file, 1);
else
Putchr(';', op_file),Putchr('\n', op_file);
if (omode == m6809)
(void)fprintf(op_file.fp, " ENTRY;\n"), Putl(op_file, 1);
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf(op_file.fp, "{ rpc_status status;\n"), Putl(op_file, 1);
Putchr('\n', op_file);
} else {
(void)fprintf(op_file.fp, "VAR\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " status : rpc_status;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "BEGIN\n"), Putl(op_file, 1);
}
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, "rp"), Putl(op_file, 0);
(void)fprintf(op_file.fp, "c_close(status, h_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ");\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, "rp"), Putl(op_file, 0);
(void)fprintf(op_file.fp, "c_report_error(status);\n"), Putl(op_file, 1);
if ((omode == pcturbo)) {
(void)fprintf(op_file.fp, " ExitProc := e_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(';', op_file),Putchr('\n', op_file);
}
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, " }\n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, "END;\n"), Putl(op_file, 1);
}
void
client_generator(client_mode, cli_name)
output_mode client_mode;
astring cli_name;
{
ptr_block_table scan;
integer proc_number;
integer *F138;
F138 = G137_proc_number;
G137_proc_number = &proc_number;
if (file_open(&op_file, &cli_name, rewriting)) {
omode = client_mode;
client = true;
fragmentation_used = false;
if (omode == pils)
client_generator_pils();
else
if (omode == vaxfor)
client_gen_for();
else {
if (!(omode == monolith))
gen_module(&op_file);
if ((omode == pcturbo)) {
(void)fprintf(op_file.fp, " e_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ": pointer;\n"), Putl(op_file, 1);
}
if ((Member((unsigned)(omode), Conset[91]))) {
(*G137_proc_number) = 1;
scan = blockptr;
while (scan != (struct S78 *)NIL) {
gen_header(&op_file, scan, false, true);
(*G137_proc_number) = (*G137_proc_number) + 1;
scan = scan->next;
}
(void)fprintf(op_file.fp, "PROCEDURE open_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(';', op_file),Putchr('\n', op_file);
(void)fprintf(op_file.fp, "PROCEDURE close_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(';', op_file),Putchr('\n', op_file);
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "IMPLEMENTATION\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
(*G137_proc_number) = 1;
scan = blockptr;
while (scan != (struct S78 *)NIL) {
if (Member((unsigned)(omode), cmode.S))
gen_client_block_c(scan);
else
gen_client_block_pas(scan);
(*G137_proc_number) = (*G137_proc_number) + 1;
scan = scan->next;
}
P71_gen_open();
P72_gen_close();
if ((Member((unsigned)(omode), Conset[92]))) {
if ((!runoptions.A[(int)(noautoinit)].value) || (omode == pcturbo))
(void)fprintf(op_file.fp, "BEGIN\n"), Putl(op_file, 1);
if ((omode == pcturbo)) {
(void)fprintf(op_file.fp, " e_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, " := ExitProc;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " ExitProc := @close_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(';', op_file),Putchr('\n', op_file);
}
if ((!runoptions.A[(int)(noautoinit)].value)) {
(void)fprintf(op_file.fp, " open_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(';', op_file),Putchr('\n', op_file);
}
(void)fprintf(op_file.fp, "END.\n"), Putl(op_file, 1);
}
if ((Member((unsigned)(omode), Conset[93])))
(void)fprintf(op_file.fp, "END .\n"), Putl(op_file, 1);
else
if ((omode == m6809))
(void)fprintf(op_file.fp, "MODEND .\n"), Putl(op_file, 1);
else
if ((omode == cerncross))
Putchr('.', op_file),Putchr('\n', op_file);
}
if (fragmentation_used)
(void)fprintf(output.fp, "Buffer fragmentation may be used for large parameters.\n"), Putl(output, 1);
if (!(file_close(&op_file)))
error(cant_cls_client);
} else
error(cant_opn_client);
G137_proc_number = F138;
}
void server_generator();
void gen_server_block();
void
write_camp()
{
(void)fprintf(op_file.fp, ", "), Putl(op_file, 0);
if ((Member((unsigned)(omode), cmode.S)) && !(runoptions.A[(int)(byvalue)].value && ((*G139_scanlist)->attr == intok)))
Putchr('&', op_file);
}
void
gen_server_block(ptr)
ptr_block_table ptr;
{
register integer a;
ptr_idlist scanlist;
integer par_count;
ptr_idlist *F140;
F140 = G139_scanlist;
G139_scanlist = &scanlist;
size_so_far = 0;
gen_header(&op_file, ptr, false, true);
{
integer B168 = 1,
B169 = ptr->blk_nesting;
if (B168 <= B169)
for (a = B168; ; a++) {
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "register rpc_integer "), Putl(op_file, 0);
(void)fprintf(op_file.fp, "rpc_%c", (unsigned)('a') - 1 + a), Putl(op_file, 0);
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, " : rpc_integer"), Putl(op_file, 0);
Putchr(';', op_file),Putchr('\n', op_file);
if (a == B169) break;
}
}
if (Member((unsigned)(omode), cmode.S))
Putchr('\n', op_file);
else {
(void)fprintf(op_file.fp, "BEGIN\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " WITH rpc_p_buf^ DO BEGIN\n"), Putl(op_file, 1);
}
if (ptr->list != (struct S77 *)NIL)
gen_pack(&op_file, ptr->list, intok, false);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, " c_turn(rpc_p_buf);\n"), Putl(op_file, 1);
else {
(void)fprintf(op_file.fp, " rpc_p_buf^.which := RETURN_MESSAGE;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " rpc_p_buf^.m_index := RETURN_HEADER_LENGTH;\n"), Putl(op_file, 1);
}
size_so_far = 0;
if ((ptr->b_type == proctok) && ptr->in_only)
if ((runoptions.A[(int)(concurrent)].value || ptr->blk_concurrent)) {
if ((Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, " c"), Putl(op_file, 0);
else
(void)fprintf(op_file.fp, " rpc"), Putl(op_file, 0);
(void)fprintf(op_file.fp, "_early_return(rpc_p_buf);\n"), Putl(op_file, 1);
} else
if (ptr->blk_cast)
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, " rpc_p_buf->m_status=1;\n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, " m_status:=1;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (ptr->b_type == functok)
dopack_simple(&op_file, ptr->C33_return, true);
write_name(&op_file, &ptr->name);
if (ptr->list != (struct S77 *)NIL) {
Putchr('(', op_file);
(*G139_scanlist) = ptr->list;
par_count = 1;
do {
if ((Member((unsigned)(omode), cmode.S)) && (Member((unsigned)((*G139_scanlist)->id_type->typ_basic_type), Conset[94])) && !(runoptions.A[(int)(byvalue)].value && ((*G139_scanlist)->attr == intok)))
Putchr('&', op_file);
if (((*G139_scanlist)->id_type->typ_basic_type == sequence)) {
(void)fprintf(op_file.fp, "a_"), Putl(op_file, 0);
write_name(&op_file, &(*G139_scanlist)->name);
par_count = par_count + 1;
write_camp();
(void)fprintf(op_file.fp, "l_"), Putl(op_file, 0);
} else
if (((*G139_scanlist)->id_type->typ_basic_type == substring)) {
(void)fprintf(op_file.fp, "a_"), Putl(op_file, 0);
write_name(&op_file, &(*G139_scanlist)->name);
write_camp();
(void)fprintf(op_file.fp, "s_"), Putl(op_file, 0);
write_name(&op_file, &(*G139_scanlist)->name);
par_count = par_count + 2;
write_camp();
(void)fprintf(op_file.fp, "l_"), Putl(op_file, 0);
} else
if (((*G139_scanlist)->id_type->typ_basic_type == stringtok) && !(Member((unsigned)(omode), (Union(cmode.S, Conset[95]))))) {
(void)fprintf(op_file.fp, "a_"), Putl(op_file, 0);
write_name(&op_file, &(*G139_scanlist)->name);
par_count = par_count + 1;
(void)fprintf(op_file.fp, ", l_"), Putl(op_file, 0);
}
Claimset();
write_name(&op_file, &(*G139_scanlist)->name);
par_count = par_count + 1;
(*G139_scanlist) = (*G139_scanlist)->next;
if ((*G139_scanlist) != (struct S77 *)NIL) {
(void)fprintf(op_file.fp, ", "), Putl(op_file, 0);
if (par_count > 3) {
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
par_count = 0;
}
}
} while (!((*G139_scanlist) == (struct S77 *)NIL));
Putchr(')', op_file);
} else
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "()"), Putl(op_file, 0);
if (ptr->b_type == functok)
Putchr(')', op_file);
Putchr(';', op_file),Putchr('\n', op_file);
if (ptr->list != (struct S77 *)NIL)
gen_pack(&op_file, ptr->list, outok, true);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, " }\n"), Putl(op_file, 1);
else {
(void)fprintf(op_file.fp, " END {with};\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "END;\n"), Putl(op_file, 1);
}
Putchr('\n', op_file);
G139_scanlist = F140;
}
void
gen_jump_proc()
{
integer proc_num;
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf(op_file.fp, "static rpc_message *rpc_p_buf;\n"), Putl(op_file, 1);
Putchr('\n', op_file);
(*G141_scan) = blockptr;
proc_num = 0;
while ((*G141_scan) != (struct S78 *)NIL) {
gen_server_block((*G141_scan));
(*G141_scan) = (*G141_scan)->next;
proc_num = proc_num + 1;
}
}
if (Member((unsigned)(omode), Conset[96]))
(void)fprintf(op_file.fp, "[GLOBAL]\n"), Putl(op_file, 1);
writok(&op_file, proctok);
(void)fprintf(op_file.fp, "r_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "(rpc_a) rpc_message **rpc_a;\n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, "(VAR rpc_p_buf : rpc_message_pointer);\n"), Putl(op_file, 1);
if (omode == m6809)
(void)fprintf(op_file.fp, " ENTRY;\n"), Putl(op_file, 1);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "{ rpc_short request;\n"), Putl(op_file, 1);
else {
(void)fprintf(op_file.fp, "VAR\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " request : rpc_short;\n"), Putl(op_file, 1);
}
if (!(Member((unsigned)(omode), cmode.S))) {
(*G141_scan) = blockptr;
proc_num = 0;
while ((*G141_scan) != (struct S78 *)NIL) {
gen_server_block((*G141_scan));
(*G141_scan) = (*G141_scan)->next;
proc_num = proc_num + 1;
}
(void)fprintf(op_file.fp, "BEGIN\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " WITH rpc_p_buf^ DO BEGIN\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " m_index :"), Putl(op_file, 0);
} else {
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " rpc_p_buf = *rpc_a;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " rpc_p_buf->m_index "), Putl(op_file, 0);
}
(void)fprintf(op_file.fp, "= CALL_HEADER_LENGTH - "), Putl(op_file, 0);
if (version_num == 0)
(void)fprintf(op_file.fp, "2;\n"), Putl(op_file, 1);
else {
(void)fprintf(op_file.fp, "4;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " upk_short(rpc_p_buf, request);\n"), Putl(op_file, 1);
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf(op_file.fp, " if (request != 0 && request != %1d)\n", version_num), Putl(op_file, 1);
(void)fprintf(op_file.fp, " rpc_p_buf->m_status = RPC_S_UNSUPPORTED_VERSION;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " else {\n"), Putl(op_file, 1);
} else {
(void)fprintf(op_file.fp, " IF (request<>0) AND (request<>%1d)\n", version_num), Putl(op_file, 1);
(void)fprintf(op_file.fp, " THEN m_status := RPC_S_UNSUPPORTED_VERSION\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " ELSE begin\n"), Putl(op_file, 1);
}
}
(void)fprintf(op_file.fp, " upk_short(rpc_p_buf, request);\n"), Putl(op_file, 1);
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf(op_file.fp, " switch (request)\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " { "), Putl(op_file, 0);
} else {
(void)fprintf(op_file.fp, " IF (request = 0) OR (request > %1d) THEN\n", proc_num), Putl(op_file, 1);
(void)fprintf(op_file.fp, " m_status := RPC_S_BAD_PROCEDURE_NUMBER\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " ELSE CASE request OF\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
}
(*G141_scan) = blockptr;
proc_num = 1;
while ((*G141_scan) != (struct S78 *)NIL) {
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "case "), Putl(op_file, 0);
(void)fprintf(op_file.fp, "%2d : r_", proc_num), Putl(op_file, 0);
write_name(&op_file, &(*G141_scan)->name);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "()"), Putl(op_file, 0);
Putchr(';', op_file),Putchr('\n', op_file);
proc_num = proc_num + 1;
(*G141_scan) = (*G141_scan)->next;
if ((Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, " break;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
}
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf(op_file.fp, "default : rpc_p_buf->m_status = RPC_S_BAD_PROCEDURE_NUMBER;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " }\n"), Putl(op_file, 1);
if (version_num != 0)
(void)fprintf(op_file.fp, " }\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " }\n"), Putl(op_file, 1);
} else {
(void)fprintf(op_file.fp, "END {case};\n"), Putl(op_file, 1);
if (version_num != 0)
(void)fprintf(op_file.fp, " END {if};\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " END {with};\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "END;\n"), Putl(op_file, 1);
}
Putchr('\n', op_file);
}
void
P73_gen_attach()
{
if (Member((unsigned)(omode), Conset[97]))
if (runoptions.A[(int)(noautoinit)].value)
(void)fprintf(op_file.fp, "[GLOBAL]\n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, "[GLOBAL, INITIALIZE]\n"), Putl(op_file, 1);
writok(&op_file, proctok);
(void)fprintf(op_file.fp, "attach_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "()\n"), Putl(op_file, 1);
else
Putchr(';', op_file),Putchr('\n', op_file);
if (Member((unsigned)(omode), cmode.S)) {
(void)fprintf(op_file.fp, "{ rpc_status status;\n"), Putl(op_file, 1);
Putchr('\n', op_file);
} else {
(void)fprintf(op_file.fp, "VAR\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " status : rpc_status;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " service : rpc_name;\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, "BEGIN\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " service := "), Putl(op_file, 0);
write_name_padded(&op_file, unitname, '\'');
Putchr(';', op_file),Putchr('\n', op_file);
}
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, "rp"), Putl(op_file, 0);
if ((Member((unsigned)(omode), Conset[98])))
(void)fprintf(op_file.fp, "c_attach_stub(status, @r_"), Putl(op_file, 0);
else
(void)fprintf(op_file.fp, "c_attach_stub(status, r_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ", "), Putl(op_file, 0);
if (Member((unsigned)(omode), cmode.S)) {
Putchr('\n', op_file);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
write_name_padded(&op_file, unitname, '"');
} else
(void)fprintf(op_file.fp, "service"), Putl(op_file, 0);
(void)fprintf(op_file.fp, ", p_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ");\n"), Putl(op_file, 1);
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, "rp"), Putl(op_file, 0);
(void)fprintf(op_file.fp, "c_report_error(status);\n"), Putl(op_file, 1);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, " }\n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, "END;\n"), Putl(op_file, 1);
}
void
P74_gen_detach()
{
if (Member((unsigned)(omode), Conset[99]))
(void)fprintf(op_file.fp, "[GLOBAL]\n"), Putl(op_file, 1);
writok(&op_file, proctok);
(void)fprintf(op_file.fp, "detach_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, "()\n"), Putl(op_file, 1);
else
Putchr(';', op_file),Putchr('\n', op_file);
if (Member((unsigned)(omode), cmode.S)) {
Putchr('{', op_file),Putchr('\n', op_file);
} else {
(void)fprintf(op_file.fp, "BEGIN\n"), Putl(op_file, 1);
}
(void)fprintf(op_file.fp, " "), Putl(op_file, 0);
if (!(Member((unsigned)(omode), cmode.S)))
(void)fprintf(op_file.fp, "rp"), Putl(op_file, 0);
(void)fprintf(op_file.fp, "c_detach_stub(p_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, ");\n"), Putl(op_file, 1);
if (Member((unsigned)(omode), cmode.S))
(void)fprintf(op_file.fp, " }\n"), Putl(op_file, 1);
else
(void)fprintf(op_file.fp, "END;\n"), Putl(op_file, 1);
}
void
server_generator(server_mode, ser_name)
output_mode server_mode;
astring ser_name;
{
ptr_block_table scan;
ptr_block_table *F142;
F142 = G141_scan;
G141_scan = &scan;
if (file_open(&op_file, &ser_name, rewriting)) {
omode = server_mode;
client = false;
fragmentation_used = false;
if (omode == pils)
server_generator_pils();
else
if (omode == vaxfor)
server_gen_for();
else {
if (!(Member((unsigned)(omode), Conset[100])))
gen_module(&op_file);
if ((Member((unsigned)(omode), Conset[101]))) {
(void)fprintf(op_file.fp, "PROCEDURE attach_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
Putchr(';', op_file),Putchr('\n', op_file);
if ((omode == pcturbo)) {
(void)fprintf(op_file.fp, "PROCEDURE r_"), Putl(op_file, 0);
write_name(&op_file, &unitname);
(void)fprintf(op_file.fp, "(VAR rpc_p_buf : rpc_message_pointer);\n"), Putl(op_file, 1);
}
Putchr('\n', op_file);
(void)fprintf(op_file.fp, "IMPLEMENTATION\n"), Putl(op_file, 1);
Putchr('\n', op_file);
}
gen_jump_proc();
if (!(Member((unsigned)(omode), Conset[102])))
P73_gen_attach();
if ((Member((unsigned)(omode), Conset[103])))
(void)fprintf(op_file.fp, "END .\n"), Putl(op_file, 1);
else
if ((omode == m6809))
(void)fprintf(op_file.fp, "MODEND .\n"), Putl(op_file, 1);
else
if ((omode == cerncross))
Putchr('.', op_file),Putchr('\n', op_file);
}
if (!(file_close(&op_file)))
error(cant_cls_server);
if (fragmentation_used)
(void)fprintf(output.fp, "Buffer fragmentation may be used for large parameters.\n"), Putl(output, 1);
} else
error(cant_opn_server);
G141_scan = F142;
}
/*
** Start of program code
*/
main(_ac, _av)
int _ac;
char *_av[];
{
argc = _ac;
argv = _av;
# ifdef STDINIT
(void)(Getx(input));
# endif
init_global();
get_parameters();
parser();
if (!file_close(&inp_file))
error(cant_cls_input);
if (!runoptions.A[(int)(version)].value) {
version_num = checksum + 1000;
(void)fprintf(output.fp, "RPCC: generated stub version number is %1d.\n", version_num), Putl(output, 1);
}
if (runoptions.A[(int)(dtree)].value) {
print_tab_types();
print_tab_blocks();
} else
if (!(ser_spec || cli_spec))
(void)fprintf(output.fp, "RPCC: no stubs specified - no code generated, hope that's okay.\n"), Putl(output, 1);
if (errorfound > 0) {
(void)fprintf(output.fp, "RPCC: %3d errors found, no code generated.\n", errorfound), Putl(output, 1);
abort();
}
if (cli_spec) {
client_generator(cli_mode, cli_name);
ext_generator(cli_mode, ext_name);
}
if (ser_spec) {
server_generator(ser_mode, ser_name);
}
exit(0);
/* NOTREACHED */
}
# undef rpc_name_length
# undef maxstring
# undef expression_length
# undef template_length
# undef error_length
# undef maxidlen
# undef numkeyword
# undef numomodes
# undef maxdim
# undef non_fragmentation_limit
# undef fragmentation_threshold
# undef rpc_default_timeout
# undef commandline
/*
** End of program code
*/
static void
Getl(f)
text *f;
{
while (f->eoln == 0)
Getx(*f);
Getx(*f);
}
static FILE *
Fopen(n, l, m)
char *n, *m;
int l;
{
FILE *f;
register char *s;
static char ch = 'A';
static char tmp[MAXFILENAME];
extern int unlink(),
strlen();
if (n == NULL)
sprintf(tmp, "/tmp/ptc%d%c", getpid(), ch++);
else {
if (l < 0)
l = strlen(n);
strncpy(tmp, n, sizeof(tmp));
for (s = &tmp[sizeof(tmp)-1]; *s == ' ' || *s == '\0' || s - tmp > l; )
*s-- = '\0';
if (tmp[sizeof(tmp)-1]) {
(void)fprintf(stderr, "Too long filename '%s'\n", n);
exit(1);
}
}
s = tmp;
if ((f = fopen(s, m)) == NULL) {
(void)fprintf(stderr, "Cannot open: %s\n", s);
exit(1);
}
if (n == NULL)
unlink(tmp);
return (f);
}
static setword Q0[] = {
1,
0x00D8
};
static setword Q1[] = {
1,
0x0002
};
static setword Q2[] = {
1,
0x00C0
};
static setword Q3[] = {
1,
0x0004
};
static setword Q4[] = {
1,
0x0018
};
static setword Q5[] = {
1,
0x00C0
};
static setword Q6[] = {
1,
0x0018
};
static setword Q7[] = {
1,
0x0018
};
static setword Q8[] = {
1,
0x00DA
};
static setword Q9[] = {
1,
0x05FF
};
static setword Q10[] = {
1,
0x0018
};
static setword Q11[] = {
1,
0x00C0
};
static setword Q12[] = {
1,
0x00C0
};
static setword Q13[] = {
1,
0x0018
};
static setword Q14[] = {
1,
0x0018
};
static setword Q15[] = {
1,
0x0018
};
static setword Q16[] = {
1,
0x00C0
};
static setword Q17[] = {
1,
0x003B
};
static setword Q18[] = {
1,
0x00C0
};
static setword Q19[] = {
1,
0x00C0
};
static setword Q20[] = {
1,
0x0018
};
static setword Q21[] = {
1,
0x00C0
};
static setword Q22[] = {
1,
0x0018
};
static setword Q23[] = {
1,
0x00C0
};
static setword Q24[] = {
1,
0x00C0
};
static setword Q25[] = {
1,
0x00C4
};
static setword Q26[] = {
1,
0x0300
};
static setword Q27[] = {
1,
0x00C2
};
static setword Q28[] = {
1,
0x00DA
};
static setword Q29[] = {
1,
0x5000
};
static setword Q30[] = {
1,
0x5000
};
static setword Q31[] = {
1,
0x0800
};
static setword Q32[] = {
1,
0x0800
};
static setword Q33[] = {
1,
0x0800
};
static setword Q34[] = {
1,
0x0800
};
static setword Q35[] = {
1,
0x2800
};
static setword Q36[] = {
1,
0x2800
};
static setword Q37[] = {
1,
0x2000
};
static setword Q38[] = {
1,
0x2000
};
static setword Q39[] = {
1,
0x00C2
};
static setword Q40[] = {
1,
0x00C2
};
static setword Q41[] = {
1,
0x0002
};
static setword Q42[] = {
1,
0x5000
};
static setword Q43[] = {
1,
0x5000
};
static setword Q44[] = {
1,
0x5000
};
static setword Q45[] = {
1,
0x5000
};
static setword Q46[] = {
3,
0x0000, 0x8009, 0x0001
};
static setword Q47[] = {
1,
0x01FF
};
static setword Q48[] = {
2,
0x0000, 0x0E00
};
static setword Q49[] = {
3,
0x0000, 0x8008, 0x0005
};
static setword Q50[] = {
3,
0x0000, 0x8008, 0x0005
};
static setword Q51[] = {
3,
0x0000, 0xA081, 0x0001
};
static setword Q52[] = {
2,
0x0000, 0x0081
};
static setword Q53[] = {
2,
0x0000, 0x0C00
};
static setword Q54[] = {
2,
0x0000, 0x0A00
};
static setword Q55[] = {
2,
0x0000, 0x0600
};
static setword Q56[] = {
2,
0x0000, 0x2030
};
static setword Q57[] = {
3,
0x0000, 0x8001, 0x0001
};
static setword Q58[] = {
3,
0x0000, 0x8004, 0x0001
};
static setword Q59[] = {
3,
0x0000, 0x8004, 0x0001
};
static setword Q60[] = {
3,
0x0000, 0x8000, 0x0001
};
static setword Q61[] = {
2,
0x0000, 0x0001
};
static setword Q62[] = {
2,
0x0000, 0x0001
};
static setword Q63[] = {
2,
0x0000, 0x0001
};
static setword Q64[] = {
2,
0x0000, 0x0001
};
static setword Q65[] = {
2,
0x0000, 0x0001
};
static setword Q66[] = {
2,
0x0000, 0x0001
};
static setword Q67[] = {
2,
0x0000, 0x0001
};
static setword Q68[] = {
2,
0x0000, 0x0001
};
static setword Q69[] = {
2,
0x0000, 0x0001
};
static setword Q70[] = {
2,
0x0000, 0x0081
};
static setword Q71[] = {
2,
0x0000, 0x0001
};
static setword Q72[] = {
2,
0x0000, 0x0001
};
static setword Q73[] = {
2,
0x0000, 0x0001
};
static setword Q74[] = {
2,
0x0000, 0x0001
};
static setword Q75[] = {
2,
0x0000, 0x0001
};
static setword Q76[] = {
2,
0x0000, 0x0001
};
static setword Q77[] = {
2,
0x0000, 0x0001
};
static setword Q78[] = {
1,
0x6000
};
static setword Q79[] = {
2,
0x0000, 0x0008
};
static setword Q80[] = {
2,
0x0000, 0x0009
};
static setword Q81[] = {
1,
0x01FF
};
static setword Q82[] = {
2,
0x0000, 0x0101
};
static setword Q83[] = {
2,
0x0000, 0x0001
};
static setword Q84[] = {
2,
0x0000, 0x0101
};
static setword Q85[] = {
4,
0x0000, 0x0000, 0x5300, 0x2C00
};
static setword Q86[] = {
4,
0x0000, 0x0000, 0x0000, 0x03FF
};
static setword Q87[] = {
4,
0x0000, 0x0000, 0x2000, 0x03FF
};
static setword Q88[] = {
8,
0x0000, 0x0000, 0x0000, 0x03FF, 0x0000, 0x8000,
0xFFFE, 0x07FF
};
static setword Q89[] = {
8,
0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x8000,
0xFFFE, 0x07FF
};
static setword Q90[] = {
4,
0x0000, 0x0000, 0x1301, 0x0C00
};
static setword Q91[] = {
4,
0x0000, 0x0000, 0x1300, 0x0C00
};
static setword Q92[] = {
6,
0x0000, 0x0000, 0x0000, 0x0000, 0xFFFE, 0x07FF
};
static setword Q93[] = {
8,
0x0000, 0x0000, 0x0000, 0x0000, 0xFFFE, 0x07FF,
0xFFFE, 0x07FF
};
static setword Q94[] = {
8,
0x0000, 0x0000, 0x4000, 0x03FF, 0xFFFE, 0x87FF,
0xFFFE, 0x07FF
};
static setword Q95[] = {
4,
0x0000, 0x0000, 0x0000, 0x03FF
};
static setword Q96[] = {
4,
0x0000, 0x0000, 0x0000, 0x03FF
};
static setword Q97[] = {
6,
0x0000, 0x0000, 0x0000, 0x0000, 0xFFFE, 0x07FF
};
static setword Q98[] = {
1,
0x0400
};
static setword Q99[] = {
1,
0x01FF
};
static setword Q100[] = {
1,
0x7FFF
};
static setword Q101[] = {
3,
0xFFFF, 0xFFFF, 0x000F
};
static setword Q102[] = {
3,
0xFFFF, 0xFFFF, 0x000F
};
static setword Q103[] = {
3,
0xFFFF, 0xFFFF, 0x0FFF
};
static setword *Conset[] = {
Q103, Q102, Q101,
Q100, Q99, Q98, Q97, Q96, Q95,
Q94, Q93, Q92, Q91, Q90, Q89,
Q88, Q87, Q86, Q85, Q84, Q83,
Q82, Q81, Q80, Q79, Q78, Q77,
Q76, Q75, Q74, Q73, Q72, Q71,
Q70, Q69, Q68, Q67, Q66, Q65,
Q64, Q63, Q62, Q61, Q60, Q59,
Q58, Q57, Q56, Q55, Q54, Q53,
Q52, Q51, Q50, Q49, Q48, Q47,
Q46, Q45, Q44, Q43, Q42, Q41,
Q40, Q39, Q38, Q37, Q36, Q35,
Q34, Q33, Q32, Q31, Q30, Q29,
Q28, Q27, Q26, Q25, Q24, Q23,
Q22, Q21, Q20, Q19, Q18, Q17,
Q16, Q15, Q14, Q13, Q12, Q11,
Q10, Q9, Q8, Q7, Q6, Q5,
Q4, Q3, Q2, Q1, Q0
};
static setptr
Union(p1, p2)
register setptr p1, p2;
{
register int i, j, k;
register setptr sp = Newset(),
p3 = sp;
j = *p1;
*p3 = j;
if (j > *p2)
j = *p2;
else
*p3 = *p2;
k = *p1 - *p2;
p1++, p2++, p3++;
for (i = 0; i < j; i++)
*p3++ = (*p1++ | *p2++);
while (k > 0) {
*p3++ = *p1++;
k--;
}
while (k < 0) {
*p3++ = *p2++;
k++;
}
return (Saveset(sp));
}
static boolean
Member(m, sp)
register unsigned int m;
register setptr sp;
{
register unsigned int i = m / (setbits+1) + 1;
if ((i <= *sp) && (sp[i] & (1 << (m % (setbits+1)))))
return (true);
return (false);
}
# ifndef SETSPACE
# define SETSPACE 256
# endif
static setptr
Currset(n,sp)
int n;
setptr sp;
{
static setword Space[SETSPACE];
static setptr Top = Space;
switch (n) {
case 0:
Top = Space;
return (0);
case 1:
if (&Space[SETSPACE] - Top <= 15) {
(void)fprintf(stderr, "Set-space exhausted\n");
exit(1);
}
*Top = 0;
return (Top);
case 2:
if (Top <= &sp[*sp])
Top = &sp[*sp + 1];
return (sp);
}
/* NOTREACHED */
}
static void
Setncpy(S1, S2, N)
register setptr S1, S2;
register unsigned int N;
{
register unsigned int m;
N /= sizeof(setword);
*S1++ = --N;
m = *S2++;
while (m != 0 && N != 0) {
*S1++ = *S2++;
--N;
--m;
}
while (N-- != 0)
*S1++ = 0;
}
static struct Set *
Alignset(Sp)
register unsigned short *Sp;
{
static struct Set tmp;
register unsigned short *tp = tmp.S;
register int i = *Sp;
while (i-- >= 0)
*tp++ = *Sp++;
return (&tmp);
}
static struct String *
Alignstr(Cp)
register char *Cp;
{
static struct String tmp;
register char *sp = tmp.A;
while (*sp++ = *Cp++)
;
return (&tmp);
}
static void
Caseerror(n)
int n;
{
(void)fprintf(stderr, "Missing case limb: line %d\n", n);
exit(1);
/* NOTREACHED */
}