/* Output from p2c, the Pascal-to-C translator */ /* From input file "rpcc.p" */ /******************************************************************** * Top-down RPC compiler - Main program * 28 May 1986 Written Antonio Pastore CERN/DD 27 Jun 86 Last update by Antonio 2 Nov 86 One output file used at a time. New options. Explicitly ask for each stub module. 30 Jan 87 .ext file produced with CLIENT stub, not server. 10 Aug 87 Use globals ser_mode & cli_mode - Nici. 1 May 88 Directives under MSDOS conditional for Turbo version Nov 88 PILS and FORTRAN generation added Include options for the environment in which the compiler will run: VAXVMS VMS operting system UNIXBSD Berkley Unix 4.2 or 4.3, or DEc Ultrix MSDOS Microsoft pascal compiler or Turbo pascal PCTURBO Turbo pascal (use with MSDOS option) ********************************************************************** * SOME TECHNICAL NOTES - AP ********************************************************************** This compiler is organized in two parts: 1) the PARSER 2) the OUTPUT GENERATOR The PARSER checks the input for SYNTACTICAL and LEXICAL errors and produces as output two trees, the TYPEs and BLOCKs trees. The TYPEs tree (pointed by TYPEPTR) is a linked list of record each describing a defined type. To each of these records is associated a 'NAME', as defined by USER, and a sub-tree describing the structure of this type. The BLOCKs tree (pointed by BLOCKPTR) is a linked list of record each describing a block, that is a PROCEDURE or FUNCTION. Each BLOCK owns a NAME, (as given by the user), and a list of PARAMETERS, pointed by '.LIST'. Each record of this list has a NAME, the parameter's name (as given by the user), and a TYPE associated to it. This is a pointer, 'type', to a TYPE, so that the BLOCKs list points to the TYPEs list if BLOCKs have parameters. The same routine as used to build a TYPE definition is used to analize a parameter declaration inside a BLOCK. The OUTPUT GENERATOR reads the BLOCKs tree and produces as output two files, the CLIENT and the SERVER stubs. These are ASCII files containing procedures/functions that pack and unpack parameters and call the RPC Run-Time System. One output generator will produce Pascal or C stubs; there is also one to produce FORTRAN, and one for PILS. ***********************************************************************/ #include /** Global declaration **/ /******************************************************************** Top-down RPC compiler - Declaration part History: 28 May 86 Written, Antonio Pastore, technical Student, DD/OC 11 Jul 86 Last update by Antonio 2 Nov 86 Options concurrent, sm6809, cm6809 added 10 Aug 87 genericC options added; structural changes - Nici. 17 Aug 87 byvalue option added - Nici. 26 Aug 87 Options timeout and version added - Nici. 1 Sep 87 Options types and pcturbo added - Nici. 26 Aug 88 Options macturbo added. Roberto Bagnara, DD/OC 1 Nov 88 Options pils added. TBL, LT. 30 Mar 89 CAST option added - TBL */ #define rpc_name_length 40 /* Must tally with RPC$CONST! */ #define MAXSTRING 255 #define expression_length 80 /* expression for compenent of composite type*/ #define template_length 10 /* Length of expression templates */ #define error_length 48 /* Length of code generator error string */ #define MAXIDLEN 25 #define NUMKEYWORD 27 /* Must = number of keywords in INIT */ #define NUMOMODES 11 /* " " " " " output_mode */ #define MAXDIM 9 #define NON_FRAGMENTATION_LIMIT 1488 /* RPC_BUFFER_SIZE-CALL_HEADER_LENGTH in the worst case */ #define FRAGMENTATION_THRESHOLD 150 /* Can break up types over this size */ #define rpc_default_timeout (-1) /* Must agree with include files */ /* The following constant should be set to take parameters from the command line. */ #define COMMANDLINE true typedef Char longstring[MAXSTRING]; typedef Char char_name[MAXIDLEN]; typedef Char char3[3]; typedef Char opt_name[10]; typedef Char template_type[template_length]; typedef Char error_string[error_length]; typedef struct astring { Char str[MAXSTRING]; long len; } astring; typedef struct pilstring { Char str[MAXSTRING]; long start, len; } pilstring; typedef struct id_name { char_name str; long len; } id_name; typedef struct expression { Char str[expression_length]; long len; } expression; /** Types related to lexical analizer and tokens **/ /****** * WARNING!!! * Be careful when changing the order of the following declaration!! *******/ /* First token, simple type, courier type */ /* Last simple type */ /* RECORD added 23 Oct TBL */ /* POINTER . . . */ /* Last courier type */ /* First attr_type */ /* Last attr_type */ /* add new tokens here */ typedef enum { chartok, bytetok, shortok, integertok, real32tok, real48tok, real64tok, real128tok, longtok, arraytok, recordtok, accesstok, sequence, stringtok, substring, package, semicolon, istok, typetok, endtok, colon, comma, opnround, clsround, oftok, intok, outok, inoutok, dot, ident, number, proctok, functok, return_, pragmatok, nultok } type_token; /* Last type */ /* p2c: rpcc.p, line 159: * Note: Line breaker spent 0.2+1.11 seconds, 597 tries on line 155 [251] */ typedef struct token_descriptor { type_token kind; union { id_name name; long value; } UU; } token_descriptor; /* Describes: an abstract data type */ /*defined_type*/ typedef struct defined_type { struct named_type *typ_name; /* The name if any */ long typ_min_size; /* the minimum size in bytes */ long typ_max_size; /* The maximum size in bytes */ long typ_nesting; /* Number of indeces needed */ struct defined_type *typ_subtype; /* Subtype for complex types */ boolean typ_external; /* External marshalling */ /* The type represented by this */ type_token typ_basic_type; union { struct { /* low is always 1 */ /* low is always 1 */ /* low is always 1 */ /* low and high can vary */ long typ_low, typ_high; /* array bounds */ } U12; struct named_type *typ_fields; /* List of subtypes */ } UU; } defined_type; /* Descibes: a Named type */ typedef struct named_type { struct named_type *nty_next; id_name nty_name; defined_type *nty_type; } named_type; /* Describes: one parameter of a procedure/function */ typedef struct id_list { struct id_list *next; id_name name; type_token attr; defined_type *id_type; } id_list; /* Describes: one procedure or function */ typedef struct block_table { struct block_table *next; id_name name; type_token b_type; type_token return_; id_list *list; boolean in_only; /* no data returned */ long blk_nesting; /* Number of indeces */ long blk_min_in, blk_max_in; /* Tot Parameter size */ long blk_min_out, blk_max_out; /* Tot Parameter size */ long blk_timeout; /* Overall timeout */ id_list *blk_status_param; /* Status parameter */ boolean blk_concurrent; /* Concurrent execution*/ boolean blk_cast; /* CAST(one way message)*/ } block_table; /* Error Codes: */ /** WARNING! * Do not change the first and the last element of the following list! **/ typedef enum { ill_basic_type, number_req, oftok_miss, simtype_req, blocks_req, ident_req, twice_declared, semicol_miss, var_attr_req, colon_miss, id_not_declared, clsround_miss, opnround_miss, package_miss, endtok_miss, char_ignored, params_miss, input_miss, comma_miss, semic_round_miss, toomany_dim, toomany_dig, proc_exp, cant_opn_input, cant_opn_client, cant_opn_server, cant_cls_client, cant_cls_server, dot_miss, positive_req, cant_cls_input, ident_reserved, istok_miss, record_miss, invalid_range, bad_proc_decl, bad_name, type_miss, return_miss, cant_opn_ext, internal_error, bad_input_name, cant_cls_ext, unexp_eof /* p2c: rpcc.p, line 321: Note: * Line breaker spent 7.6+0.43 seconds, 5000 tries on line 250 [251] */ } err_type; typedef enum { rewriting, resetting } open_mode; /* *** WARNING: IF YOU MODIFY THIS DECLARATION:- 1. Check that NUMOMODES in the constant section matches the number of entries 2. Check that order of the the server and client options below matches - Nici */ /* ** SEE Note: */ typedef enum { cerncross, m6809, monolith, vaxvms, vaxpas, unixbsd, pcturbo, macturbo, pils, vaxfor, genericc } output_mode; /****** * WARNING!!! * Think carefully before changing the order of the following declaration!!! (AP) *******/ /* See output_mode */ /* add new options here */ typedef enum { ccerncross, cm6809, cmonolith, cvaxvms, cvaxpas, cunixbsd, cpcturbo, cmacturbo, cpils, cvaxfor, cgenericc, scerncross, sm6809, smonolith, svaxvms, svaxpas, sunixbsd, spcturbo, smacturbo, spils, svaxfor, sgenericc, dlex, dlexhot, dtree, shortint, stdescr, concurrent, noautoinit, byvalue, timeout, version, types, invalid /* p2c: rpcc.p, line 321: * Note: Line breaker spent 1.0+0.82 seconds, 575 tries on line 283 [251] */ } options; /** deb_lex For lexical analizer **/ /** deb_lex_hot Prints each character read from input **/ /** deb_tree To print trees created by parse **/ /* cerncross Cern Cross Software enviroment m6809 Omegasoft Pascal for the m6809 monolith Any monolithic Pascal compiler vaxvms Vax/Vms pascal fortran-like vaxpas Vax/Vms pascal unixbsd Unix BSD enviroment pcturbo IBM PC Turbo Pascal macturbo Macintosh Turbo Pascal pils Any standard PILS environonment vaxfor VAX/FORTRAN under VMS (might be portable) genericc Any generic C compiler shortint forces short (16 bit) rpc_integer stdescr pass strings by descriptor (not implemented yet) concurrent return before processing if all parameters IN noautoinit supress automatic initialisation of stubs (VMS) byvalue pass all simple type parameters by value - Nici. timeout specify value of timeout parameter - Nici. version control stub version number handling - Nici. types include user types in ".ext" file - Nici. */ typedef struct _REC_keyword { char_name name; type_token symbol; } _REC_keyword; typedef struct _REC_runoptions { opt_name name; boolean value; } _REC_runoptions; /** This variable is the HEAD pointer to the TYPE's list table **/ Static named_type *typeptr; /** This variable is the HEAD pointer to the BLOCK's list table **/ Static block_table *blockptr; Static id_name unitname; /** Name of the unit under analysis **/ /** Vars related to lexical analizer and tokens **/ Static long checksum; /** used for stub version number **/ Static boolean is_blank; /** for skipping multiple blanks **/ Static Char ch_there; /** for read-ahead in getchar(); **/ Static Char lastcar; /** Last char read **/ Static Char oldchar; /** Char ready for next request **/ Static boolean char_ready; /** Is a char ready to be returned? **/ Static boolean incomment; /** We are checking for comment **/ Static long lastindex; /** Index to the last token read **/ Static token_descriptor token, lastoken; Static boolean tok_present; /** If a token already present in lex-analizer **/ Static long lineread; /** Number of line read **/ Static long maxkeyword; /** Number of keyword, should be the same as NUMKEYWORD **/ Static _REC_keyword keyword[NUMKEYWORD]; Static Char upkpck[2][3]; /*'upk','pck'*/ Static defined_type *simple_descriptor[(long)longtok - (long)chartok + 1]; /* Reference definitions of simple types */ /* Variables set by parser: */ Static boolean external_marshalling; /* has been invoked */ Static long number_of_invented_types; /* Used by ensure_named_type */ /** General flag for errors **/ Static long errorfound; /** File variables **/ Static FILE *inp_file; /** Input file **/ Static astring inp_name; /** Input file name **/ Static pilstring inp_line; /** Last line read **/ Static FILE *op_file; /** Output file for stub &c **/ Static astring cli_name; /** Client file name **/ Static astring ser_name; /** Server file name **/ Static astring ext_name; /** External declaration file **/ /* Variables for use by Code generator: */ Static long next_label; /** Next label value for use in FORTRAN **/ Static long size_so_far; /** Number of bytes packed/unpacked so far **/ Static boolean fragmentation_used; /** have we resorted to fragmentation? **/ /* General options */ Static boolean deref, dr_tmp; /** dereferencing flag for C params **/ Static boolean cli_spec, ser_spec; /** forbid multiple stub generation **/ Static output_mode omode, ser_mode, cli_mode; Static boolean client; /** We are making a client stub now **/ Static long Cmode; /** must contain all C output modes **/ Static long timeout_val; /** value of timeout, if specified **/ Static long version_num; /** stub version number, if given **/ /** Debugging variables **/ Static _REC_runoptions runoptions[(long)invalid - (long)ccerncross + 1]; /** Error management **/ /******************************************************************** * Top-down RPC compiler - Error management * * Author: * Antonio Pastore, Tec. Student 1986, DD/OC, CERN 28 May 1986 Written, AP 23 Nov 1988 'expected' written, find_tok made less verbose. TBL ***********************************************************************/ Static Void getoken PV(); Static Void backtoken PV(); Static Void error(which) err_type which; { printf("ERROR: "); errorfound++; if ((unsigned long)which > (int)unexp_eof) { printf( "RPCC: Panic: compiler internal error, notify the compiler's Administrator.\n"); return; } switch (which) { case ill_basic_type: printf("Illegal basic type.\n"); break; case invalid_range: printf("Upper bound must be greater then lower.\n"); break; case number_req: printf("Number requested.\n"); break; case oftok_miss: printf("Keyword \"of\" missing.\n"); break; case simtype_req: printf("Simple type requested.\n"); break; case positive_req: printf("Index must be positive.\n"); break; case ident_req: printf("Identifier requested.\n"); break; case blocks_req: printf("At least a procedure/function declaration requested.\n"); break; case bad_proc_decl: printf("Parameter must be simple or already declared in type section.\n"); break; case twice_declared: printf("Identifier already declared.\n"); break; case semicol_miss: printf("Semicolon \";\" missing.\n"); break; case semic_round_miss: printf("Semicolon \";\" or round bracket \")\" missing.\n"); break; case comma_miss: printf("Comma \",\" missing.\n"); break; case var_attr_req: printf("\"in\",\"out\" or \"in out\" required.\n"); break; case colon_miss: printf("Colon \":\" missing.\n"); break; case dot_miss: printf("Dot \".\" missing.\n"); break; case id_not_declared: printf("Identifier not declared.\n"); break; case clsround_miss: printf("Round bracket \")\" missing.\n"); break; case opnround_miss: printf("Round bracket \"(\" missing.\n"); break; case package_miss: printf("Keyword \"package\" missing.\n"); break; case record_miss: printf("Keyword \"record\" missing.\n"); break; case return_miss: printf("Keyword \"return\" missing.\n"); break; case istok_miss: printf("Keyword \"is\" missing.\n"); break; case endtok_miss: printf("Keyword \"end\" missing.\n"); break; case type_miss: printf("Keyword \"type\", \"procedure\" or \"function\" missing.\n"); break; case char_ignored: printf("Illegal character:\"%c\", ignored.\n", lastcar); break; case toomany_dig: printf("Too many digits in this number.\n"); break; case toomany_dim: printf("Too many dimensions in this array.\n"); break; case ident_reserved: printf("Identifier reserved for compiler use.\n"); break; case bad_name: printf("Identifier does not match already declared package name.\n"); break; case proc_exp: printf("Keyword \"procedure\" or \"function\" expected.\n"); break; case params_miss: printf("Parameters missing.\n"); break; case input_miss: printf("Input file missing, can't go on.\n"); break; case bad_input_name: printf("Bad input file name: \".ext\" extension reserved.\n"); break; case cant_opn_input: printf("Can't open input file.\n"); break; case cant_opn_ext: printf("Can't open \".ext\" file.\n"); break; case cant_opn_client: printf("Can't open client file.\n"); break; case cant_opn_server: printf("Can't open server file.\n"); break; case cant_cls_input: printf("Can't close input file.\n"); break; case cant_cls_client: printf("Can't close client file.\n"); break; case cant_cls_server: printf("Can't close server file.\n"); break; case cant_cls_ext: printf("Can't close \".ext\" file.\n"); break; case internal_error: printf("Sorry - Unexpected internal condition in compiler.\n"); break; case unexp_eof: printf("Unexpected end of input file.\n"); break; }/*End_CASE*/ } /*ERROR*/ /* Write a token name ------------------ */ Static Void write_token(what) type_token what; { if ((unsigned long)what > (int)nultok) { printf("(Unknown token!)"); return; } switch (what) { case chartok: printf("RPC_CHAR"); break; case bytetok: printf("RPC_BYTE"); break; case shortok: printf("RPC_SHORT"); break; case integertok: printf("RPC_INTEGER"); break; case real32tok: printf("RPC_REAL32"); break; case real48tok: printf("RPC_REAL48"); break; case real64tok: printf("RPC_REAL64"); break; case real128tok: printf("RPC_REAL128"); break; case longtok: printf("RPC_LONG"); break; case arraytok: printf("ARRAY"); break; case sequence: printf("SEQUENCE"); break; case stringtok: printf("STRING"); break; case substring: printf("SUBSTRING"); break; case package: printf("PACKAGE"); break; case semicolon: printf("SEMICOLON"); break; case typetok: printf("TYPE"); break; case endtok: printf("END"); break; case colon: printf("colon \":\""); break; case comma: printf("comma \",\""); break; case opnround: printf("\"(\""); break; case clsround: printf("\")\""); break; case oftok: printf("OF"); break; case intok: printf("IN"); break; case outok: printf("OUT"); break; case inoutok: printf("INOUT"); break; case istok: printf("IS"); break; case return_: printf("RETURN"); break; case dot: printf("\".\""); break; case ident: printf("identifier"); break; case number: printf("number"); break; case proctok: printf("PROCEDURE"); break; case functok: printf("FUNCTION "); break; case nultok: printf("(Null Token!)"); break; } } /*write_token*/ /* Print last line read from declaration file ------------------------------------------ On entry: 'lastindex' is the index of the last token read. */ Static Void print_last_line() { long a, FORLIM; printf("INPUT:"); FORLIM = inp_line.len; for (a = 0; a < FORLIM; a++) putchar(inp_line.str[a]); putchar('\n'); FORLIM = lastindex + 4; for (a = 1; a <= FORLIM; a++) putchar('-'); printf("^\n"); } Static Void linerror(which) err_type which; { printf("RPCC: Error found on line %3ld:\n", lineread); print_last_line(); error(which); putchar('\n'); } Static Void find_tok(kind) long *kind; { /** writeln('RPCC: Skipping ...'); **/ while (!P_inset(token.kind, kind)) getoken(); /** print_last_line; writeln('RPCC: Restarting analysis here.'); writeln; **/ } Static Void errfind(which, kind) err_type which; long *kind; { linerror(which); find_tok(kind); } Static Void abort_pgm(which) err_type which; { error(which); printf("Fatal error, program aborted.\n"); _Escape(0); } /** Debugging module **/ /******************************************************************** * Top-down RPC compiler - Debugging module * * Author: * Antonio Pastore, Tec. Student 1986, DD/OC, CERN * * History: * 28 May 1986 first written (AP) * 27 Jun 1986 last update by AP * 26 Aug 1987 bug fix in print_tab_types - Nici. * ***********************************************************************/ Static Void debug_print_name(where, name) FILE **where; id_name name; { long i; for (i = 0; i < name.len; i++) putc(name.str[i], *where); } Static Void printok(what) type_token what; { if ((unsigned long)what > (int)nultok) { printf("?????? (bad type token) ???"); return; } switch (what) { case chartok: printf("RPC_CHAR"); break; case bytetok: printf("RPC_BYTE"); break; case shortok: printf("RPC_SHORT"); break; case integertok: printf("RPC_INTEGER"); break; case real32tok: printf("RPC_REAL32"); break; case real48tok: printf("RPC_REAL48"); break; case real64tok: printf("RPC_REAL64"); break; case real128tok: printf("RPC_REAL128"); break; case longtok: printf("RPC_LONG"); break; case arraytok: printf("ARRAY"); break; case sequence: printf("SEQUENCE"); break; case stringtok: printf("STRING"); break; case substring: printf("SUBSTRING"); break; case package: printf("PACKAGE"); break; case semicolon: printf("SEMICOLON"); break; case typetok: printf("TYPE"); break; case endtok: printf("END"); break; case colon: printf("COLON"); break; case comma: printf("COMMA"); break; case opnround: printf("OPNROUND"); break; case clsround: printf("CLSROUND"); break; case oftok: printf("OF"); break; case intok: printf("IN "); break; case outok: printf("OUT "); break; case inoutok: printf("IN OUT "); break; case istok: printf("IS"); break; case return_: printf("RETURN"); break; case dot: printf("DOT"); break; case ident: printf("IDENT"); break; case number: printf("NUMBER"); break; case proctok: printf("PROCEDURE"); break; case functok: printf("FUNCTION "); break; case nultok: printf("NULTOKEN"); break; } } /*PRINT*/ /*_____________________________________________________________________________ Print out a type definition Prints out whole lines. */ /* indenting function */ Static long indent(level) long level; { return (level * 4 + 16); } Static Void print_def_type(ptr, level) defined_type *ptr; long level; { named_type *scan; FILE *TEMP; named_type *WITH1; if (ptr == NULL) { printf("???? NIL pointer ????"); return; } if (((1L << ((long)ptr->typ_basic_type)) & ((1L << ((long)substring + 1)) - (1L << ((long)chartok)))) == 0) { printf("???? Bad basic type ????"); return; } if ((level > 1 || ((1L << ((long)ptr->typ_basic_type)) & ((1L << ((long)longtok + 1)) - (1L << ((long)chartok)))) != 0) && ptr->typ_name != NULL) { /* p2c: rpcc.p, line 706: Note: * Line breaker spent 2.2+3.13 seconds, 1526 tries on line 1024 [251] */ printf("%*c", (int)indent(level), ' '); /* Use predefined name if possible */ TEMP = stdout; /* p2c: rpcc.p, line 655: * Note: Taking address of stdout; consider setting VarFiles = 0 [144] */ debug_print_name(&TEMP, ptr->typ_name->nty_name); printf(";\n"); return; } switch (ptr->typ_basic_type) { case chartok: case bytetok: case shortok: case integertok: case real32tok: case real48tok: case real64tok: case real128tok: case longtok: printf("%*c", (int)indent(level), ' '); printok(ptr->typ_basic_type); printf("; -- ??? unnamed basic type ???\n"); break; case stringtok: printf("%*cSTRING (%ld);\n", (int)indent(level), ' ', ptr->UU.U12.typ_high); break; case arraytok: printf("%*cARRAY (%ld..%ld) OF\n", (int)indent(level), ' ', ptr->UU.U12.typ_low, ptr->UU.U12.typ_high); print_def_type(ptr->typ_subtype, level + 1); break; case accesstok: printf("%*cACCESS\n", (int)indent(level), ' '); print_def_type(ptr->typ_subtype, level + 1); break; case recordtok: printf("%*cRECORD\n", (int)indent(level), ' '); scan = ptr->UU.typ_fields; while (scan != NULL) { WITH1 = scan; printf("%*c", (int)indent(level + 1), ' '); TEMP = stdout; /* p2c: rpcc.p, line 689: * Note: Taking address of stdout; consider setting VarFiles = 0 [144] */ debug_print_name(&TEMP, WITH1->nty_name); printf(": \n"); print_def_type(WITH1->nty_type, level + 2); scan = scan->nty_next; /*while*/ } printf("%*cEND RECORD;\n", (int)indent(level), ' '); break; case sequence: printf("%*cSEQUENCE (%ld) OF \n", (int)indent(level), ' ', ptr->UU.U12.typ_high); print_def_type(ptr->typ_subtype, level + 1); break; case substring: printf("%*cSUBSTRING (%ld);\n", (int)indent(level), ' ', ptr->UU.U12.typ_high); break; }/*end_case*/ } /*PRINT_DEF_TYPE*/ Static Void print_tab_types() { /**** * This procedure prints on standard output the tree of the type's declaration. ****/ named_type *scan; options a; FILE *TEMP; defined_type *WITH; printf("\n-- Compiler options requested:\n\n"); for (a = ccerncross; (long)a <= (long)invalid; a = (options)((long)a + 1)) { if (runoptions[(long)a - (long)ccerncross].value) printf("-- Option %.10s is set.\n", runoptions[(long)a - (long)ccerncross].name); } printf("\n\n-- Tree of types (alphabetical order)\n\n"); scan = typeptr; while (scan != NULL) { printf("TYPE "); TEMP = stdout; /* p2c: rpcc.p, line 731: * Note: Taking address of stdout; consider setting VarFiles = 0 [144] */ debug_print_name(&TEMP, scan->nty_name); printf(" IS \n"); print_def_type(scan->nty_type, 1L); WITH = scan->nty_type; if (WITH->typ_max_size == WITH->typ_min_size) printf(" -- Representation: %ld bytes.\n", WITH->typ_max_size); else printf(" -- Representation: %ld bytes minimum, %ld bytes maximum.\n", WITH->typ_min_size, WITH->typ_max_size); /* p2c: rpcc.p, line 743: * Note: Line breaker spent 1.1 seconds, 4 tries on line 1133 [251] */ putchar('\n'); scan = scan->nty_next; } /*end_while*/ } /*PRINT_TAB_TYPES*/ Local Void print_list(ptr) id_list *ptr; { printf("with parameters:\n"); do { printf(" %.*s : ", MAXIDLEN, ptr->name.str); printok(ptr->attr); if (ptr->id_type->typ_name != NULL) printf("%.*s", MAXIDLEN, ptr->id_type->typ_name->nty_name.str); else print_def_type(ptr->id_type, 1L); putchar('\n'); ptr = ptr->next; } while (ptr != NULL); printf("(end of parameters)"); } Static Void print_tab_blocks() { /**** * This procedure prints on standard output the tree of the block's declaration. ****/ block_table *scan; printf("\n################## TREE OF BLOCKS #######################\n\n"); printf("PACKAGE %.*s IS\n", MAXIDLEN, unitname.str); scan = blockptr; while (scan != NULL) { putchar('\n'); printok(scan->b_type); printf(" %.*s", MAXIDLEN, scan->name.str); if (scan->list != NULL) print_list(scan->list); if (scan->b_type == functok) { printf(" RETURN "); printok(scan->return_); } printf("\n-- Minimum %ld bytes in, %ld out.\n", scan->blk_min_in, scan->blk_min_out); printf("-- Maximum %ld bytes in, %ld out.\n", scan->blk_max_in, scan->blk_max_out); printf("-- _______________________________________________________\n"); scan = scan->next; } /*end_while*/ printf("END %.*s;\n\n", MAXIDLEN, unitname.str); } Static Void print_token() { printf(" Token read: "); if (token.kind == ident) printf("IDENT:\"%.*s\"", MAXIDLEN, token.UU.name.str); else { if (token.kind == number) printf("NUMBER: %12ld", token.UU.value); else printok(token.kind); } putchar('\n'); } /*PRINT_TOKEN*/ Local Void put_keyword(name, tok) Char *name; type_token tok; { maxkeyword++; memcpy(keyword[maxkeyword - 1].name, name, sizeof(char_name)); keyword[maxkeyword - 1].symbol = tok; } /** Global initialization **/ /******************************************************************** * Top-down RPC compiler - Initialization code * * Author: * Antonio Pastore, Tec. Student 1986, DD/OC, CERN * History: 28 May 86 Written, Antonio Pastore, Technical student, DD/OC 11 Jul 86 Last update by antonio 2 Nov 86 Extra options added (TBL) 10 Aug 87 genericC options added; structural changes - Nici. 17 Aug 87 byvalue option added - Nici. 26 Aug 87 Options timeout and version added - Nici. 1 Sep 87 Options types and pcturbo added - Nici. 26 Aug 88 Options macturbo added. Roberto Bagnara, DD/OC 23 Oct 88 RECORD and ACCESS added - Tim BL 1 Nov 88 PILS output options added (Louis Tremblet) ***********************************************************************/ Static Void getoken_init() { /** Vars in getoken **/ inp_line.len = 0; inp_line.start = 0; lastindex = 1; lineread = 0; tok_present = false; lastcar = ' '; char_ready = false; incomment = false; /** The following MUST be in alphabetical order !!! **/ maxkeyword = 0; put_keyword("access ", accesstok); put_keyword("array ", arraytok); put_keyword("end ", endtok); put_keyword("function ", functok); put_keyword("in ", intok); put_keyword("inout ", inoutok); put_keyword("is ", istok); put_keyword("of ", oftok); put_keyword("out ", outok); put_keyword("package ", package); put_keyword("pragma ", pragmatok); put_keyword("procedure ", proctok); put_keyword("record ", recordtok); put_keyword("return ", return_); put_keyword("rpc_byte ", bytetok); put_keyword("rpc_char ", chartok); put_keyword("rpc_integer ", integertok); put_keyword("rpc_long ", longtok); put_keyword("rpc_real128 ", real128tok); put_keyword("rpc_real32 ", real32tok); put_keyword("rpc_real48 ", real48tok); put_keyword("rpc_real64 ", real64tok); put_keyword("rpc_short ", shortok); put_keyword("sequence ", sequence); put_keyword("string ", stringtok); put_keyword("substring ", substring); put_keyword("type ", typetok); memcpy(upkpck[0], "upk", 3L); /* Part of output of code generator */ memcpy(upkpck[true], "pck", 3L); } Static Void inp_options() { options opt; for (opt = ccerncross; (long)opt <= (long)invalid; opt = (options)((long)opt + 1)) runoptions[(long)opt - (long)ccerncross].value = false; memcpy(runoptions[(long)cmonolith - (long)ccerncross].name, "cmonolith ", sizeof(opt_name)); memcpy(runoptions[0].name, "ccerncross", sizeof(opt_name)); memcpy(runoptions[(long)cm6809 - (long)ccerncross].name, "cm6809 ", sizeof(opt_name)); memcpy(runoptions[(long)cvaxvms - (long)ccerncross].name, "cvaxvms ", sizeof(opt_name)); memcpy(runoptions[(long)cvaxpas - (long)ccerncross].name, "cvaxpas ", sizeof(opt_name)); memcpy(runoptions[(long)cunixbsd - (long)ccerncross].name, "cunixbsd ", sizeof(opt_name)); memcpy(runoptions[(long)cpcturbo - (long)ccerncross].name, "cpcturbo ", sizeof(opt_name)); memcpy(runoptions[(long)cmacturbo - (long)ccerncross].name, "cmacturbo ", sizeof(opt_name)); memcpy(runoptions[(long)cpils - (long)ccerncross].name, "cpils ", sizeof(opt_name)); memcpy(runoptions[(long)cvaxfor - (long)ccerncross].name, "cfortran ", sizeof(opt_name)); memcpy(runoptions[(long)cgenericc - (long)ccerncross].name, "cgenericc ", sizeof(opt_name)); memcpy(runoptions[(long)smonolith - (long)ccerncross].name, "smonolith ", sizeof(opt_name)); memcpy(runoptions[(long)scerncross - (long)ccerncross].name, "scerncross", sizeof(opt_name)); memcpy(runoptions[(long)sm6809 - (long)ccerncross].name, "sm6809 ", sizeof(opt_name)); memcpy(runoptions[(long)svaxvms - (long)ccerncross].name, "svaxvms ", sizeof(opt_name)); memcpy(runoptions[(long)svaxpas - (long)ccerncross].name, "svaxpas ", sizeof(opt_name)); memcpy(runoptions[(long)sunixbsd - (long)ccerncross].name, "sunixbsd ", sizeof(opt_name)); memcpy(runoptions[(long)spcturbo - (long)ccerncross].name, "spcturbo ", sizeof(opt_name)); memcpy(runoptions[(long)smacturbo - (long)ccerncross].name, "smacturbo ", sizeof(opt_name)); memcpy(runoptions[(long)spils - (long)ccerncross].name, "spils ", sizeof(opt_name)); memcpy(runoptions[(long)svaxfor - (long)ccerncross].name, "sfortran ", sizeof(opt_name)); memcpy(runoptions[(long)sgenericc - (long)ccerncross].name, "sgenericc ", sizeof(opt_name)); memcpy(runoptions[(long)dlex - (long)ccerncross].name, "dlex ", sizeof(opt_name)); memcpy(runoptions[(long)dlexhot - (long)ccerncross].name, "dlexhot ", sizeof(opt_name)); memcpy(runoptions[(long)dtree - (long)ccerncross].name, "dtree ", sizeof(opt_name)); memcpy(runoptions[(long)shortint - (long)ccerncross].name, "shortint ", sizeof(opt_name)); memcpy(runoptions[(long)stdescr - (long)ccerncross].name, "stdescr ", sizeof(opt_name)); memcpy(runoptions[(long)concurrent - (long)ccerncross].name, "concurrent", sizeof(opt_name)); memcpy(runoptions[(long)noautoinit - (long)ccerncross].name, "noautoinit", sizeof(opt_name)); memcpy(runoptions[(long)byvalue - (long)ccerncross].name, "byvalue ", sizeof(opt_name)); memcpy(runoptions[(long)timeout - (long)ccerncross].name, "timeout ", sizeof(opt_name)); memcpy(runoptions[(long)version - (long)ccerncross].name, "version ", sizeof(opt_name)); memcpy(runoptions[(long)types - (long)ccerncross].name, "types ", sizeof(opt_name)); Cmode = 1L << ((long)genericc); ser_name.len = 0; ser_mode = cerncross; ser_spec = false; cli_name.len = 0; cli_mode = cerncross; cli_spec = false; checksum = 0; ch_there = ' '; is_blank = true; } Static Void pointers_init() { typeptr = NULL; blockptr = NULL; } Static Void init_global() { getoken_init(); inp_options(); pointers_init(); errorfound = 0; } /** Input parameters management **/ /******************************************************************** * Top-down RPC compiler - Parameters management * * Author: * Antonio Pastore, Tec. Student 1986, DD/OC, CERN * 28 May 1986 Written (Antonio) 27 Jun 1986 Last update by Antonio 12 Feb 87 No longer overwrites existing files: makes new version 10 Aug 87 get_argv (UNIXBSD): string length bug fixed; options "[s,c]=" implemented; bug fix: disallow problematic MAGIC characters; catch multiple server/client specifications - Nici. 26 Aug 87 Options timeout and version added - Nici. 20 Mar 88 For loop vaiable was used after loop in Unix file open Subsctring function now used in VMS file open. 15 Dec 88 Bug fix: filename with 10 char long option was ignored ***********************************************************************/ /* M A C H I N E D E P E N D A N T R O U T I N E S ============= ================= =============== These are: get_argc(count) Return number of arguments get_argv(index, str, len) Return one argument as a string file_open(file, name, mode) Open a file file-close(file) Close a file */ Static Void get_argc(count) long *count; { *count = P_argc - 1; /** Predefined identifier **/ } Static Void get_argv(what, towhere, len) long what; Char *towhere; long *len; { boolean loop; P_sun_argv(towhere, sizeof(longstring), (int)what); /** * Remember: * command line parameters are truncated or padded with blanks!! **/ *len = 0; loop = true; while (loop && *len <= MAXSTRING) { if (towhere[*len] != ' ') (*len)++; else loop = false; } } Static boolean file_open(file_des, name, mode) FILE **file_des; astring *name; open_mode mode; { /*** * Try to open a file with 'name' name, returns true if succesful, * false otherwise. ***/ long a; longstring str; long FORLIM; Char STR1[256]; FORLIM = name->len; for (a = 0; a < FORLIM; a++) str[a] = name->str[a]; a = name->len; /* 80320 */ if (a < MAXSTRING) a++; str[a - 1] = '\0'; if (mode == rewriting) { if (*file_des != NULL) { sprintf(STR1, "%.*s", MAXSTRING, str); *file_des = freopen(STR1, "w", *file_des); } else { sprintf(STR1, "%.*s", MAXSTRING, str); *file_des = fopen(STR1, "w"); } if (*file_des == NULL) _EscIO(FileNotFound); return true; } if (*file_des != NULL) { sprintf(STR1, "%.*s", MAXSTRING, str); *file_des = freopen(STR1, "r", *file_des); } else { sprintf(STR1, "%.*s", MAXSTRING, str); *file_des = fopen(STR1, "r"); } if (*file_des == NULL) _EscIO(FileNotFound); return true; } Static boolean file_close(file_des) FILE **file_des; { fflush(*file_des); P_ioresult = 0; return true; } #define MAGIC1 "-" /* ugly! This disallows magic charcter '-' for */ #define MAGIC2 "-" /* E N D O F M A C H I N E D E P E N D A N T B I T ****************************************************************************** */ /* Analize an option: ----------------- If interactive skip MAGIC and don't set input file name. The spelling of the name of this procedure is historical. */ Static Void analize(arg, len, interactive) Char *arg; long len; boolean interactive; { opt_name loc_arg; long a, i; boolean found; options scan; boolean present; /* Parameter present */ Char STR1[256], STR2[256]; long FORLIM; sprintf(STR1, "%c", arg[0]); sprintf(STR2, "%c", arg[0]); /* Options are at most 10 characters long, but may be followed by an '=' sign which must be scanned and may be in position 11. */ if (((strcmp(STR1, MAGIC1) == 0) | (strcmp(STR2, MAGIC2) == 0)) || interactive) /** Options **/ { /** Option **/ memcpy(loc_arg, " ", sizeof(opt_name)); a = 1; present = false; while (a <= 11 && a < len && !present) { if (arg[a] == '=') present = true; else if (a <= 10) { if (isupper(arg[a])) loc_arg[a - 1] = _tolower(arg[a]); else loc_arg[a - 1] = arg[a]; } a++; } /** Find options **/ scan = ccerncross; found = false; /** if present then a := a + 1; skip over "=" out 90926 **/ do { if (!strncmp(loc_arg, runoptions[(long)scan - (long)ccerncross].name, sizeof(opt_name))) { found = true; if ((int)scan < NUMOMODES) { /*client specification*/ if (cli_spec) { printf("RPCC: "); for (a = 0; a < len; a++) putchar(arg[a]); printf(": client already specified - option ignored.\n"); } else { cli_spec = true; for (i = 1; i <= (int)scan; i++) cli_mode = (output_mode)((long)cli_mode + 1); if (present) { cli_name.len = len - a; FORLIM = len - a; for (i = 0; i < FORLIM; i++) cli_name.str[i] = arg[a + i]; } } } else if ((int)scan < NUMOMODES * 2) { if (ser_spec) { printf("RPCC: "); for (a = 0; a < len; a++) putchar(arg[a]); printf(": server already specified - option ignored.\n"); } else { ser_spec = true; for (i = 1; i <= (int)scan - NUMOMODES; i++) ser_mode = (output_mode)((long)ser_mode + 1); if (present) { ser_name.len = len - a; FORLIM = len - a; for (i = 0; i < FORLIM; i++) ser_name.str[i] = arg[a + i]; } } } else { runoptions[(long)scan - (long)ccerncross].value = true; if (scan == timeout) { if (a >= len) { printf("RPCC: timeout value missing, default will be used.\n"); runoptions[(long)timeout - (long)ccerncross].value = false; } else { timeout_val = 0; FORLIM = len - a; for (i = 0; i < FORLIM; i++) { if (isdigit(arg[a + i])) timeout_val = timeout_val * 10 + arg[a + i] - '0'; else { printf("RPCC timeout option: "); abort_pgm(number_req); } } if (timeout_val == 0) printf("RPCC: timeout is zero, hope that's okay.\n"); } } else if (scan == version) { if (a >= len) { printf("RPCC: supplying missing version number.\n"); runoptions[(long)version - (long)ccerncross].value = false; } else { version_num = 0; FORLIM = len - a; for (i = 0; i < FORLIM; i++) { if (isdigit(arg[a + i])) version_num = version_num * 10 + arg[a + i] - '0'; else { printf("RPCC version option: "); abort_pgm(number_req); } } if (version_num == 0) printf("RPCC: stub version check disabled.\n"); } } } } else scan = (options)((long)scan + 1); } while (!(found || scan == invalid)); if (scan != invalid) return; printf("RPCC: "); for (a = 0; a < len; a++) putchar(arg[a]); printf(": unrecognized option, ignored.\n"); return; } inp_name.len = len; for (a = 0; a < len; a++) inp_name.str[a] = arg[a]; /*server specification*/ /*a REAL option*/ /** File name **/ } /*ANALIZE*/ #undef MAGIC1 #undef MAGIC2 /* Make a filename out of the input file name and a prefix ------------------------------------------------------- The prefix is put on the front of the name part of the filename. This is taken to be the last bit which contains only alphanumerics and dots and underscores. Other characters are assumed to be directory information, which must be left intact. */ Static Void make_filename(filename, prefix) astring *filename; Char *prefix; { long i, rdp; /* read pointer */ boolean done; long FORLIM; rdp = inp_name.len; /* point to last char */ done = false; /* Find start of name - a horrible Pascal loop */ do { /* Oh, to be programming in C at this point! */ if (rdp >= 1) { if (inp_name.str[rdp - 1] == '_' || inp_name.str[rdp - 1] == '.' || isalnum(inp_name.str[rdp - 1])) rdp--; else done = true; } else done = true; } while (!done); /* rdp is the number of characters of directory etc preceding the filename*/ filename->len = 0; for (i = 0; i < rdp; i++) { filename->len++; filename->str[filename->len - 1] = inp_name.str[i]; } for (i = 0; i <= 2; i++) { filename->len++; filename->str[filename->len - 1] = prefix[i]; } FORLIM = inp_name.len; for (i = rdp; i < FORLIM; i++) { filename->len++; filename->str[filename->len - 1] = inp_name.str[i]; } } Static Void get_parameters() { /***** * On entry: parameters on the command line * On exit: * 'inp_name' filled with input file name; * 'inp_file' opened using 'inp_name' name; * 'cli_name' filled with client file name; ('cli'+inp_name) * 'ser_name' filled with server file name; ('ser'+inp_name) * 'ext_name' filled with the external file name; (inp_name.'ext') *******/ long a, b, count, p_argc, p_len; longstring p_argv; Char ext[3]; /* TBL 14-8-86 */ inp_name.len = 0; if (COMMANDLINE) { count = 1; get_argc(&p_argc); while (count <= p_argc) { get_argv(count, p_argv, &p_len); count++; /** Analize option **/ analize(p_argv, p_len, false); } /*end_while*/ } else { printf("Input file name: "); inp_name.len = 0; while (!P_eoln(stdin) && inp_name.len <= MAXSTRING) { inp_name.len++; inp_name.str[inp_name.len - 1] = getchar(); if (inp_name.str[inp_name.len - 1] == '\n') inp_name.str[inp_name.len - 1] = ' '; } /** Skip end of line **/ scanf("%*[^\n]"); getchar(); /** Get options **/ do { printf("Debugging options: "); count = 1; while (!P_eoln(stdin) && count < MAXSTRING) { count++; p_argv[count - 1] = getchar(); if (p_argv[count - 1] == '\n') p_argv[count - 1] = ' '; } scanf("%*[^\n]"); getchar(); /** Analize option **/ if (count > 1) analize(p_argv, count, true); } while (count != 1); } if (inp_name.len == 0) { printf("RPCC: usage: source_file [options]\n"); abort_pgm(input_miss); } /** Try to open input file **/ if (!file_open(&inp_file, &inp_name, resetting)) abort_pgm(cant_opn_input); /** Build client, server and external default file names **/ if (cli_name.len == 0) make_filename(&cli_name, "cli"); if (ser_name.len == 0) make_filename(&ser_name, "ser"); /* Make the external declaration file name: Th extension is changed to '.ext' */ b = inp_name.len; while (b >= 1 && isalpha(inp_name.str[b - 1])) /*then*/ b--; if (b == 0) /* No '.' found */ b = inp_name.len; if (inp_name.str[b - 1] != '.') /* Found directory */ b = inp_name.len; for (a = 0; a < b; a++) { if (a + 1 <= MAXSTRING - 3) ext_name.str[a] = inp_name.str[a]; } if (b <= inp_name.len - 3) { /* extension was specified */ ext[0] = inp_name.str[b]; ext[1] = inp_name.str[b + 1]; ext[2] = inp_name.str[b + 2]; if (!strncmp(ext, "ext", 3) || !strncmp(ext, "EXT", 3)) abort_pgm(bad_input_name); } else { /*if*/ b++; /* Add a '.' if it wasn't */ ext_name.str[b - 1] = '.'; } ext_name.str[b] = 'e'; ext_name.str[b + 1] = 'x'; ext_name.str[b + 2] = 't'; ext_name.len = b + 3; /** Get file name **/ } /*GET_PARAMETERS*/ #define TAB 9 /** ASCII TAB character **/ /*** * Note: 'lastcar' is declared global to be printed in error messages. ***/ Local Char AP_getchar() { /** renamed - Nici, 26 Aug 87 **/ Char Result; long a; Char localcar; long FORLIM; if (char_ready) { Result = oldchar; char_ready = false; return Result; } while (inp_line.start > inp_line.len || inp_line.len == 0) { inp_line.len = 0; inp_line.start = 1; lastindex = 1; if (P_eof(inp_file)) { abort_pgm(unexp_eof); continue; } while (!P_eoln(inp_file)) { inp_line.len++; inp_line.str[inp_line.len - 1] = getc(inp_file); if (inp_line.str[inp_line.len - 1] == '\n') inp_line.str[inp_line.len - 1] = ' '; if (inp_line.str[inp_line.len - 1] == TAB) inp_line.str[inp_line.len - 1] = ' '; /** Convert TAB to space **/ else { if (inp_line.str[inp_line.len - 1] < 32) inp_line.len--; } } inp_line.len++; inp_line.str[inp_line.len - 1] = ' '; fscanf(inp_file, "%*[^\n]"); /** Skip END_OF_LINE **/ getc(inp_file); lineread++; /** Line counter **/ if (runoptions[(long)dlex - (long)ccerncross].value) { printf("LINE READ: "); FORLIM = inp_line.len; for (a = 0; a < FORLIM; a++) putchar(inp_line.str[a]); putchar('\n'); } } localcar = inp_line.str[inp_line.start - 1]; inp_line.start++; /*END_WITH*/ /** Make it lower **/ if (isupper(localcar)) localcar = _tolower(localcar); Result = localcar; /** Skip comment if any **/ if (localcar != '-' || incomment) return Result; incomment = true; oldchar = AP_getchar(); incomment = false; if (oldchar == '-') { inp_line.len = 0; /** Force the reading of a new line **/ return ' '; /** Return space **/ } Result = localcar; char_ready = true; return Result; /*END_ELSE char_ready*/ } /*AP_GETCHAR*/ #undef TAB Local Char getchar_() { /** written - Nici, 26 Aug 87 **/ /** This rather complex interface ensures that blanks are skipped **/ /** whenever they are not syntactically relevant, in order to make **/ /** the checksum of syntactically identical RPCL files invariant. **/ Char ch; if (ch_there != ' ') { ch = ch_there; ch_there = ' '; } else { ch = AP_getchar(); if (ch == ' ') { if (!P_eof(inp_file)) { do { ch = AP_getchar(); } while (ch == ' '); } if (!(ch == ';' || ch == ',' || ch == ')' || ch == '(' || ch == ':' || is_blank)) { ch_there = ch; ch = ' '; } } } is_blank = (ch == ';' || ch == ',' || ch == ')' || ch == '(' || ch == ':' || ch == ' '); checksum = (checksum * 3 + ch - ' ') % 8999; /* p2c: rpcc.p, line 1476: * Note: Using % for possibly-negative arguments [317] */ if (!runoptions[(long)dlexhot - (long)ccerncross].value) return ch; if (ch == ' ') printf("%c\n", ch); else putchar(ch); return ch; } /** Getoken, lexical analizer **/ /******************************************************************** * Top-down RPC compiler - Lexical analizer * * Author: * Antonio Pastore, Tec. Student 1986, DD/OC, CERN * * History: * 28 May 1986 first written (AP) * 27 Jun 1986 last update by AP * 26 Aug 1987 checksum (for version) included - Nici. * 16 Nov 1988 Bug fix: crashed with 26 char identifier (TBL) * ***********************************************************************/ /*GETOKEN returns in TOKEN (globally declared) the last token read*/ Static Void getoken() { long i, j, k, sign; /* _____________________________________________________________________________ */ if (tok_present) { token = lastoken; tok_present = false; } else { do { /** Find a valid token **/ if (lastcar == ' ') /** Skip blank **/ lastcar = getchar_(); lastindex = inp_line.start; /** To print error messages **/ /** Check if identifier or keyword **/ if (lastcar == '_' || islower(lastcar)) { /** Suppose to be an identifier or keyword **/ token.kind = ident; token.UU.name.len = 0; do { if (token.UU.name.len < MAXIDLEN) { /* was <= 81116 TBL */ token.UU.name.len++; token.UU.name.str[token.UU.name.len - 1] = lastcar; } lastcar = getchar_(); } while (lastcar == '_' || islower(lastcar) || isdigit(lastcar)); /** Fill with blanks **/ for (i = token.UU.name.len; i < MAXIDLEN; i++) token.UU.name.str[i] = ' '; /** Try to see if keyword **/ /** The following is the famous binary search!!! **/ i = 1; j = maxkeyword; do { k = (i + j) / 2; if (strncmp(token.UU.name.str, keyword[k - 1].name, sizeof(char_name)) <= 0) j = k - 1; if (strncmp(token.UU.name.str, keyword[k - 1].name, sizeof(char_name)) >= 0) i = k + 1; } while (i <= j); if (i - 1 > j) token.kind = keyword[k - 1].symbol; else { /** Check if illegal identifier, reserved for compiler use **/ if ((token.UU.name.str[0] == 'r' && token.UU.name.str[1] == 'p' && token.UU.name.str[2] == 'c' && token.UU.name.str[3] == '_') || !strncmp(token.UU.name.str, "b ", sizeof(char_name)) || !strncmp(token.UU.name.str, "header ", sizeof(char_name)) || !strncmp(token.UU.name.str, "ret ", sizeof(char_name))) /* p2c: rpcc.p, line 1583: Note: * Line breaker spent 5.3+2.40 seconds, 2464 tries on line 2041 [251] */ linerror(ident_reserved); token.kind = ident; } } /*identifier or keyword*/ else { /** Check if number **/ if (lastcar == '-' || isdigit(lastcar)) { /*if number*/ token.kind = number; token.UU.value = 0; if (lastcar == '-') { sign = -1; lastcar = getchar_(); } else sign = 1; do { if (token.UU.value < LONG_MAX / 10 - lastcar + '0') token.UU.value = token.UU.value * 10 + lastcar - '0'; else { error(toomany_dig); token.UU.value = LONG_MAX; } lastcar = getchar_(); } while (isdigit(lastcar)); token.UU.value *= sign; } else { /*if*/ /** Then should be one of these symbols! **/ if (lastcar != '.' && lastcar != ')' && lastcar != '(' && lastcar != ',' && lastcar != '=' && lastcar != ';' && lastcar != ':') { token.kind = nultok; error(char_ignored); /** Ignore this character **/ } else { switch (lastcar) { case ':': token.kind = colon; break; case ';': token.kind = semicolon; break; case ',': token.kind = comma; break; case '(': token.kind = opnround; break; case ')': token.kind = clsround; break; case '.': token.kind = dot; break; }/*end case*/ } /*if*/ lastcar = getchar_(); /** Read next char **/ } } } while (token.kind == nultok); /*END_WITH*/ } /*end_token already present*/ if (runoptions[(long)dlex - (long)ccerncross].value) print_token(); } /*getoken*/ /* _____________________________________________________________________________ */ Static Void backtoken() { /**** * This procedure save the value of 'tok' and uses it when next 'getoken' is * called. *****/ lastoken = token; tok_present = true; } /** Parser **/ /* Top-down RPC compiler PARSE.PAS PARSER, types and blocks declaration ==================================== History: 28 May 86 Written, Antonio Pastore, Tec. Student '86, DD/OC, CERN 30 Jun 86 Last change by Antonio 18 Aug 86 Bug fix in block_declare (TBL) (block.list not initzd). 31 Oct 86 Direction defaults to IN (TBL) 20 Oct 88 Nested complex types (TBL) 23 Nov 88 PRAGMAs timeout, external_marshalling introduced (TBL) 30 Mar 89 PRAGMA CAST introducted (TBL) 10 Oct 89 Bug fix: Looped on PRAGMA CAST(); General useful routines ----------------------- Check for a given token, otherwise skip expected --------------------------------------- */ Static boolean expected(what, skip_until) type_token what; long *skip_until; { boolean Result; getoken(); if (token.kind == what) return true; Result = false; printf("RPCC: Error: Found "); write_token(token.kind); printf(" where "); write_token(what); printf(" was expected on line %ld:\n", lineread); print_last_line(); putchar('\n'); find_tok(skip_until); return Result; /*if*/ } /*_______________________________________________________________________________ Expression handling append_1 =================== An expression is a variable length string generated by the compiler. The following routines add bits on to an existing expression to make it more complicated: Append one character to an expression: ------------------------------------- */ Static Void append_1(expr, ch) expression *expr; Char ch; { expr->len++; expr->str[expr->len - 1] = ch; } /* p2c: rpcc.p, line 1661: Warning: Unrecognized character in file [247] */ /* Format an expression according to a template format -------------------------------------------- The template is a 10-character character array which contains a dollar sign wherever the original value of the expression is to be put. */ Static Void format(final, template) expression *final; Char *template; { /* On entry, template must not be blank. On exit, expression copied from template with original expression inserted in place of "$" signs. */ expression initial; long e; /* effective end of template string*/ long i, j; /* loop index */ /*format*/ initial = *final; final->len = 0; e = template_length; while (template[e - 1] == ' ') /* strip spaces */ e--; for (i = 0; i < e; i++) { /*for*/ if (template[i] == '$') { for (j = 0; j < initial.len; j++) append_1(final, initial.str[j]); } else append_1(final, template[i]); } } /* Put one character on the front of an expression prepend_1 ----------------------------------------------- */ Static Void prepend_1(expr, ch) expression *expr; Char ch; { long a; for (a = expr->len; a >= 1; a--) expr->str[a] = expr->str[a - 1]; expr->str[0] = ch; expr->len++; } /* Append an identifier to an expression append_name ------------------------------------- */ Static Void append_name(expr, name) expression *expr; id_name name; { long a; for (a = 0; a < name.len; a++) append_1(expr, name.str[a]); } /* p2c: rpcc.p, line 1717: Warning: Unrecognized character in file [247] */ /* Append an index to an array expression append_index -------------------------------------- The `level' parameter determines the name of the index to be used. 1 -> rpc_a, 2 -> rpc_b etc. */ Static Void append_index(expr, level) expression *expr; long level; { format(expr, "$[rpc_ "); append_1(expr, (Char)(level + 96)); append_1(expr, ']'); } /* Append a decimal number to an expression append_decimal ---------------------------------------- */ Static Void append_decimal(expr, x) expression *expr; long x; { long t, weight; if (x < 0) { append_1(expr, '-'); t = -x; } else t = x; weight = 1; /* these are array bounds */ while (weight * 10 <= t) weight *= 10; /* weight is largest power of 10 not greater than t */ while (weight > 0) { /*while*/ append_1(expr, (Char)(t / weight + '0')); t %= weight; /* p2c: rpcc.p, line 1750: * Note: Using % for possibly-negative arguments [317] */ weight /= 10; } } /* p2c: rpcc.p, line 1754: Warning: Unrecognized character in file [247] */ /* Find Type in List find_type ----------------- The TYPE table used to be in alphabetical order, to halve search time. However, now it is kept in the order or original declaration, as we allow types to be defined in terms of other types. When the type table is repoduced in C or Pascal, we don't want any forward references. This routine not only searches for existing types, but also is used to find the previous element ("father"), when inserting into a list. On entry head is the head pointer of the list to be searched, in which the elements are in order. name is the name to be searched for. On exit, father is set to the father of this element if any, otherwise will point to the last element in the list. son is a pointer to that element if found, NIL otherwise. returns true if element found else false. Parameter 'name' is 'var' to speed up the processing. */ Static boolean find_type(head, name, father, son) named_type *head; id_name *name; named_type **father, **son; { /* head of list*/ boolean found; found = false; *son = head; /** Head of the list **/ *father = *son; while (*son != NULL && !found) { if (!strncmp((*son)->nty_name.str, name->str, sizeof(char_name))) found = true; else { *father = *son; *son = (*son)->nty_next; } } return found; } /* p2c: rpcc.p, line 1802: Warning: Unrecognized character in file [247] */ /* Insert Type Identifier into list insert_named_type -------------------------------- On entry, ptr points to a description of the named type. head is the pointer to a list of named types. On exit, The element pointed to has been put into the list. */ Static Void insert_named_type(ptr, head) named_type *ptr, **head; { named_type *son, *father; /*insert_named_type*/ if (find_type(*head, &ptr->nty_name, &father, &son)) { linerror(twice_declared); /** Identifier already declared **/ return; } if (*head == NULL) { /** List empty **/ *head = ptr; ptr->nty_next = NULL; return; } if (*head == son) { /** Insert ahead **/ *head = ptr; ptr->nty_next = son; } else { father->nty_next = ptr; ptr->nty_next = son; } } /* p2c: rpcc.p, line 1835: Warning: Unrecognized character in file [247] */ /* Find Procedure or Function name find_block ------------------------------- This functions looks for 'name' in the table of blocks, then returns a pointer to that element if found, NIL otherwise. 'Father' will be set to the father of this element if any, otherwise will point to the last element in the list. Anyway should be good enough to insert elements in queue. Input is 'var' to speed up the processing. */ Static boolean find_block(name, father, son) id_name *name; block_table **father, **son; { boolean found; found = false; *son = blockptr; /** Head of the list **/ *father = *son; while (*son != NULL && !found) { /*while*/ if (!strncmp((*son)->name.str, name->str, sizeof(char_name))) found = true; else { *father = *son; *son = (*son)->next; } } return found; } /* Find parameter find_param -------------- On exit, son pointer to param if found, else NIL return value TRUE if found else FALSE */ Static boolean find_param(name, head, son) id_name *name; id_list *head, **son; { boolean found; *son = head; found = false; while (*son != NULL && !found) { /*while*/ if (!strncmp((*son)->name.str, name->str, sizeof(char_name))) found = true; else *son = (*son)->next; } return found; } /* p2c: rpcc.p, line 1887: Warning: Unrecognized character in file [247] */ /* TYPE DECLARATION ANALIZER ========================= The following routines analize the TYPE declaration and create the proper structure to handle them later. Ensure Type Named ensure_type_named ----------------- If the given type is not named, then this procedure will invent an arbitrary name for it, of the form rpc_stype_nnn where nnn is an incrementing decimal number. */ Static Void ensure_type_named(pt) defined_type *pt; { long i; /* String index */ expression expr; /* for building up the variable name */ named_type *pnt; /* Pointer to the new named type if any */ if (pt == NULL) return; if (pt->typ_name != NULL) /*if with if*/ return; pnt = (named_type *)Malloc(sizeof(named_type)); format(&expr, "rpc_stype_"); append_decimal(&expr, number_of_invented_types); number_of_invented_types++; for (i = 0; i < expr.len; i++) pnt->nty_name.str[i] = expr.str[i]; pnt->nty_name.len = expr.len; pnt->nty_type = pt; /* Link name to type */ pt->typ_name = pnt; /* Link type to name */ insert_named_type(pnt, &typeptr); /* Put into the type list */ /*with*/ } /* p2c: rpcc.p, line 1930: Warning: Unrecognized character in file [247] */ /* p2c: rpcc.p, line 1982: Warning: Unrecognized character in file [247] */ Static defined_type *parse_type PV(); /* p2c: rpcc.p, line 2069: Warning: Unrecognized character in file [247] */ /* Parse: ( ) get_size ----- Error recovery: If error found we suppose token forgotten so we 'backtoken'. */ Local Void get_size(pt) defined_type *pt; { long SET[3]; getoken(); if (token.kind != opnround) linerror(opnround_miss); else getoken(); pt->UU.U12.typ_low = 1; /* implied lower bound */ if (token.kind != number) { linerror(number_req); /** Assume zero **/ pt->UU.U12.typ_high = 0; } else { pt->UU.U12.typ_high = token.UU.value; getoken(); } if (token.kind != clsround) { errfind(clsround_miss, P_expset(SET, (1L << ((long)oftok)) | (1L << ((long)semicolon)))); /* p2c: rpcc.p, line 2223: * Note: Line breaker spent 4.6 seconds, 106 tries on line 2543 [251] */ backtoken(); } if (pt->UU.U12.typ_high < 0) /*with*/ linerror(positive_req); } /*GET_SIZE*/ /* Parse Sub-array parse_sub_array --------------- subarray :: .. ] of | .. , Sub-array is not really a good word for this - it's the tail of an array definition, which can recursively call itself. These sort of things come out of pure BNF definitions, and avoid loops, even if they contain unnested brackets! On entry, First number token not read. On exit, token read/not read as after parse_type. value points to type descriptor filled in (except possibly for name) Note that a subarray is the only thing which can have an unnamed subtype. */ Local defined_type *parse_subarray() { defined_type *pt; long SET[3]; pt = (defined_type *)Malloc(sizeof(defined_type)); pt->typ_name = NULL; pt->typ_external = false; pt->typ_subtype = NULL; /* Until filled in with good value */ pt->typ_basic_type = arraytok; /* The type is "array" */ getoken(); if (token.kind != number) { linerror(number_req); /** Assume zero **/ pt->UU.U12.typ_low = 0; } else { pt->UU.U12.typ_low = token.UU.value; getoken(); } /** Skip double point **/ if (token.kind == dot) { getoken(); if (token.kind != dot) linerror(dot_miss); else getoken(); } else linerror(dot_miss); if (token.kind != number) { linerror(number_req); /** Assume low + 1 **/ pt->UU.U12.typ_high = pt->UU.U12.typ_low + 1; } else { pt->UU.U12.typ_high = token.UU.value; getoken(); } if (pt->UU.U12.typ_high <= pt->UU.U12.typ_low) linerror(invalid_range); if (token.kind == comma) pt->typ_subtype = parse_subarray(); /* , */ else if (token.kind == clsround) { getoken(); if (token.kind == oftok) { getoken(); pt->typ_subtype = parse_type(); /* ) of */ /*** ensure_type_named(typ_subtype); *NO* **/ } else { /*if*/ errfind(clsround_miss, P_expset(SET, 1L << ((long)semicolon))); /* ) garbage */ backtoken(); } } else { errfind(clsround_miss, P_expset(SET, (1L << ((long)oftok)) | (1L << ((long)semicolon)))); backtoken(); } if (pt->typ_subtype == NULL) { /*with*/ Free(pt); /* Not essential -could waste it */ return NULL; } else { /*if*/ pt->typ_min_size = (pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1) * pt->typ_subtype->typ_min_size; pt->typ_max_size = (pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1) * pt->typ_subtype->typ_max_size; pt->typ_nesting = pt->typ_subtype->typ_nesting + 1; return pt; } /*if*/ } /*parse_subarray*/ /* Parse Type parse_type ---------- In this function we analize a TYPE definition and return a pointer to a type descriptor tree. Returns: Returns a pointer to a new created element otherwise nil if error Error recovery: If error found we exit with the offending token in 'backtoken'. */ Static defined_type *parse_type() { defined_type *Result, *pt; named_type *pnt; boolean loc_err; named_type *father, *son; long SET[3]; /* Parse Type definition (main block) parse_type --------------------- main block :: | SEQUENCE ( ) OF | ARRAY ( .. ) OF | STRING ( ) | SUBSTRING ( ) | RECORD [ : ; ]* END RECORD | On entry, TOKEN ALREADY READ On exit, Next token (semicolon) not read Return value points to filled-in type descriptor, or NIL if error */ if (token.kind == ident) { /* */ if (find_type(typeptr, &token.UU.name, &father, &son)) return (son->nty_type); linerror(id_not_declared); return Result; } else if ((unsigned long)token.kind < 32 && ((1L << ((long)token.kind)) & ((1L << ((long)longtok + 1)) - (1L << ((long)chartok)))) != 0) { /* p2c: rpcc.p, line 2223: Note: * Line breaker spent 1.4+4.47 seconds, 441 tries on line 2691 [251] */ return (simple_descriptor[(long)token.kind - (long)chartok]); } else if (token.kind == arraytok) { getoken(); if (token.kind != opnround) { linerror(opnround_miss); backtoken(); return NULL; } else return (parse_subarray()); } else if (token.kind == accesstok) { pt = (defined_type *)Malloc(sizeof(defined_type)); pt->typ_basic_type = token.kind; pt->typ_external = false; getoken(); pt->typ_subtype = parse_type(); ensure_type_named(pt->typ_subtype); if (pt->typ_subtype == NULL) /*if*/ return pt; pt->typ_nesting = pt->typ_subtype->typ_nesting; /* No extra index */ pt->typ_min_size = 4; /* */ pt->typ_max_size = pt->typ_subtype->typ_max_size + 4; /* */ return pt; } else if (token.kind == recordtok) { pt = (defined_type *)Malloc(sizeof(defined_type)); Result = pt; pt->typ_basic_type = token.kind; pt->typ_external = false; pt->typ_subtype = NULL; /* subtype is meaningless */ pt->UU.typ_fields = NULL; /* List of fields currently empty */ pt->typ_nesting = 0; /* Unless we find nesting in a subtype */ pt->typ_min_size = 0; /* Initialise total */ pt->typ_max_size = 0; /* Initialise total */ getoken(); while (token.kind == ident) { /*while token.kind=ident*/ pnt = (named_type *)Malloc(sizeof(named_type)); /** It's ok, create an element **/ pnt->nty_name = token.UU.name; getoken(); if (token.kind != colon) /* : (or ignore)*/ linerror(colon_miss); else getoken(); pnt->nty_type = parse_type(); /* Analyse a type declaration*/ if (pnt->nty_type != NULL) /*if ok*/ { /* Unless serious error, */ if (pnt->nty_type->typ_nesting > pt->typ_nesting) /* Find max. nesting */ pt->typ_nesting = pnt->nty_type->typ_nesting; pt->typ_min_size += pnt->nty_type->typ_min_size; pt->typ_max_size += pnt->nty_type->typ_max_size; insert_named_type(pnt, &pt->UU.typ_fields); ensure_type_named(pnt->nty_type); /* Needed for FORTRAN? */ } getoken(); /* Read next token: ";" */ if (token.kind != semicolon) { /** Error recovery: Skip tokens until a good token is found **/ errfind(semicol_miss, P_expset(SET, (1L << ((long)semicolon)) | (1L << ((long)endtok)))); if (token.kind == semicolon) /** Skip it **/ getoken(); } else /** Semicolon found **/ getoken(); } /*with*/ if (token.kind != endtok) errfind(endtok_miss, P_expset(SET, 1L << ((long)endtok))); getoken(); /* skip the END */ if (token.kind == recordtok) return Result; linerror(record_miss); if (token.kind == semicolon) /* Assume he forgot RECORD */ backtoken(); return Result; } else if (token.kind == sequence) { pt = (defined_type *)Malloc(sizeof(defined_type)); pt->typ_basic_type = token.kind; Result = pt; get_size(pt); getoken(); if (token.kind != oftok) { /** But ignore it **/ linerror(oftok_miss); return Result; } getoken(); pt->typ_external = false; pt->typ_subtype = parse_type(); /** ensure_type_named(typ_subtype); *NO* not needed **/ pt->typ_nesting = pt->typ_subtype->typ_nesting + 1; pt->typ_min_size = 2; pt->typ_max_size = pt->typ_subtype->typ_max_size * (pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1) + 2; /*if*/ return Result; } else if ((unsigned long)token.kind < 32 && ((1L << ((long)token.kind)) & ((1L << ((long)stringtok)) | (1L << ((long)substring)))) != 0) { /* p2c: rpcc.p, line 2223: Note: * Line breaker spent 3.1+1.80 seconds, 509 tries on line 2806 [251] */ pt = (defined_type *)Malloc(sizeof(defined_type)); Result = pt; pt->typ_basic_type = token.kind; get_size(pt); pt->typ_subtype = simple_descriptor[0]; pt->typ_external = false; if (pt->typ_basic_type == stringtok) { /*with*/ pt->typ_nesting = 2; /* Can be 2 or 1 needed actually. */ pt->typ_max_size = pt->UU.U12.typ_high + 2; pt->typ_min_size = 2; return Result; } pt->typ_nesting = 1; pt->typ_max_size = pt->UU.U12.typ_high + 4; pt->typ_min_size = 4; return Result; } else { linerror(ill_basic_type); loc_err = true; backtoken(); return NULL; } return Result; /* Simple types */ /* ARRAY ( */ /* ACCESS */ /* R E C O R D */ /* SEQUENCE (...) OF */ /* Substring */ /*if*/ } /*parse_type*/ /* p2c: rpcc.p, line 2225: Warning: Unrecognized character in file [247] */ /* Parse PRAGMA clause parse_pragma ------------------- Parses: :: PRAGMA TIMEOUT ( ,