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