Programmer's ROM - The Computer Language Library

home *** CD-ROM | disk | FTP | other *** search

/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / stubs / stub2.src < prev next >

Wrap

Text File | 1988-05-03 | 125.5 KB | 3,085 lines

--:::::::::: --stub2.dis --:::::::::: -- STUBBER 2.0 stubber.pro -- The following files are in compilation order osdepc3.ada getoken.ada stubber.ada stubsup.ada -- The following files, in compilation order, are used to test STUBBER 2.0 stubtest.spc stubtest.bdy --:::::::::: --stubber.pro --:::::::::: -------- SIMTEL20 Ada Software Repository Prologue ------------ -- -* -- Unit name : Body Stubber -- Version : 2.0 -- Author : Joseph M. Orost -- : Concurrent Computer Corporation -- : 106 Apple St -- : Tinton Falls, NJ 07724 -- DDN Address : petsd!joe@RUTGERS.EDU -- Date created : 15 July 1983 -- Release date : -- Last update : 5 May 1987 -- Compiled by : Concurrent Computer Corporation C3Ada R00-01 -- -* --------------------------------------------------------------- -- -* -- Keywords : ----------------: -- -- Abstract : This program reads an Ada specification ----------------: and generates a corresponding Body with ----------------: stubs for all subprograms. ----------------: All of the OS dependencies are contained in ----------------: the OS_DEPENDENCIES package. ----------------: ----------------: Version 1.0: ----------------: This tool was developed as a precursor for ----------------: the WMCCS Information System (WIS). An ----------------: executable version of the tool has been ----------------: demonstrated. This source code has sub- ----------------: sequently been recompiled but has not under- ----------------: gone extensive testing. ----------------: ----------------: Version 2.0: ----------------: Complete overhaul. All non-Ansi Ada ----------------: dependencies removed. Bugs fixed/ ----------------: Enhancements: ----------------: Task specifications are now stubbed. ----------------: Pragma INTERFACE now suppresses stubs. ----------------: OUTPUT_LINE_LENGTH parameter - not ----------------: exceeded. ----------------: Output properly indented and aligned. ----------------: Overwrite of output file now asks ----------------: permission. ----------------: Comments and declarations from spec ----------------: included in stub. ----------------: Spec is no longer duplicated in output. ----------------: ID Comment is generated on "begin". ----------------: Execution-time message now is fully ----------------: qualified. ----------------: Exception handler part is now a source ----------------: parameter. ----------------: Multiple specs in input file now works. ----------------: Generic "with procedure" or "with ----------------: function" now not taken as declaration ----------------: to be stubbed. ----------------: In addition, many code speed-ups are ----------------: included. ----------------: ----------------: Rehosting is performed by modifying the ----------------: package OS_DEPENDENCIES: (file OSDEPxxx.ADA) ----------------: Select the output line length. ----------------: Select the indent amount and indent limit. ----------------: Select the standard suffix for the ----------------: input/output files. ----------------: Code ADD_SUFFIX to insert the suffix into ----------------: the filename. -- -* ------------------ Revision history --------------------------- -- -* -- DATE VERSION AUTHOR HISTORY -- 07/15/83 1.0 Steven E. Nameroff Initial Release -- 05/05/87 2.0 Joseph M. Orost Major rewrite -- -* ------------------ Distribution and Copyright ----------------- -- -* -- This prologue must be included in all copies of this software. -- -- This software is released to the Ada community. -- This software is released to the Public Domain (note: -- software released to the Public Domain is not subject -- to copyright protection). -- Restrictions on use or distribution: NONE -- -* ----------------- Disclaimer ---------------------------------- -- -* -- This software and its documentation are provided "AS IS" and -- without any expressed or implied warranties whatsoever. -- -- No warranties as to performance, merchantability, or fitness -- for a particular purpose exist. -- -- Because of the diversity of conditions and hardware under -- which this software may be used, no warranty of fitness for -- a particular purpose is offered. The user is advised to -- test the software thoroughly before relying on it. The user -- must assume the entire risk and liability of using this -- software. -- -- In no event shall any person or organization of people be -- held responsible for any direct, indirect, consequential -- or inconsequential damages or lost profits. -- -* ----------------- Known Problems ----------------------------- -- -- The stubber does not handle task declarations with entry -- families that are specified other than: -- (integer_LB .. integer_UB) -- In this case, the body stub contains ACCEPT statements for -- all family members IN integer_LB .. integer_UB. -- -- Entry families specified by -- (TYPE_NAME) or -- (TYPE_NAME'RANGE) -- will cause a legal body to be generated, but only 1 accept -- statement (for TYPE_NAME'FIRST) is generated. A warning -- message is produced. -- -- Entry families of the form: -- (Expression .. Expression) -- causes illegal code produced in the body stub. A warning -- message is produced. -- ----------------- END-PROLOGUE ------------------------------- --:::::::::: --osdepc3.ada --:::::::::: -- -- -- package OS_DEPENDENCIES -- -- -- -- This version for Concurrent Computer Corporation -- -- C3Ada R00-01 -- -- -- ------------------------------------------------------------------------ ------------------------------------------------------------------------ with TEXT_IO; use TEXT_IO; package OS_DEPENDENCIES is --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Package OS_DEPENDENCIES is designed to support all of the -- -- packages that use file input/output with the OS operating -- -- system. It includes all of the peculiarities and machine- -- -- dependencies that are not part of the Ada language. These -- -- include getting characters (GETC), and new OPEN and CREATE -- -- CREATE commands which automatically trans- -- -- late file names (from GET_FILENAME) to suit the OS filer. -- -- -- -- The package was written so that a programmer needs to only -- -- change this package to meet another system, to use any of -- -- the other routines in the STUBBER. -- -- -- -- Author: Steven E. Nameroff, C1C, USAF -- -- Date : 15 July 1983 -- -- Updated: 4/28/87 J. Orost, Concurrent Computer Corporation -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- --Set this to TRUE to generate an exception handler in the stub --which prints a message. If FALSE, no exception handler is declared --in the stub. Use FALSE is your Ada compiler already provides a --walkback on unhandled exceptions. GENERATE_EXCEPTION_PART : constant BOOLEAN := TRUE; --Compiler dependent OUTPUT_LINE_LENGTH : constant := 80; --Host dependent INDENT_AMOUNT : constant := 3; --User preference INDENT_LIMIT : constant := 27; --User preference procedure GETC (FILE : in FILE_TYPE; CHAR : out CHARACTER; POSITION : in out INTEGER); package OS_FILE_OPS is -- all required due to -- the filer OPEN_SUFFIX : constant STRING := ".SPC"; --Host dependent CREATE_SUFFIX : constant STRING := ".BDY"; --Host dependent function GET_FILENAME return STRING; procedure OPEN (FILE_NAME : in out FILE_TYPE; LONG_NAME : in STRING; SUFFIX : in STRING := OPEN_SUFFIX); procedure CREATE (FILE_NAME : in out FILE_TYPE; LONG_NAME : in STRING; SUFFIX : in STRING := CREATE_SUFFIX); -- All other file operations are the same as TEXT_IO -- versions, so are not needed here. end OS_FILE_OPS; -- specifications. end OS_DEPENDENCIES; -- specifications. ------------------- package body OS_DEPENDENCIES ---------------------- ------------------------------------------------------------------------ with TEXT_IO; use TEXT_IO; with ADA_IO_SERVICES; --CCUR use ADA_IO_SERVICES; --CCUR package body OS_DEPENDENCIES is ENDFILE : constant CHARACTER := CHARACTER'VAL (28); ---------------------------------------------------------------------- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- ---------------------------------------------------------------------- package body OS_FILE_OPS is --------------------------------------------------------- -- This package contains all of the procedures that -- -- are necessary for using files with the OS filer -- -- system. -- --------------------------------------------------------- -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - function GET_FILENAME return STRING is ------------------------------------------ -- This procedure accepts input from -- -- the terminal for a correct system -- -- file name. -- ------------------------------------------ INPUT_LINE : STRING (1 .. 72); LENGTH_OF_INPUT : NATURAL; begin PUT ("Enter name of file (suffix """); PUT (OPEN_SUFFIX); PUT (""" assumed) : "); NEW_LINE; --CCUR GET_LINE (INPUT_LINE, LENGTH_OF_INPUT); return INPUT_LINE (1 .. LENGTH_OF_INPUT); end GET_FILENAME; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --This routine is the where most of the host dependencies are --located. function ADD_SUFFIX (NAME : in STRING; --host dependent SUFFIX : in STRING; --CCUR REPLACE : in BOOLEAN) return STRING is --CCUR ------------------------------------------ -- This procedure adds the necessary -- -- suffix to the name that the user -- -- gave in GET_FILENAME to make it a -- -- legal system file name. -- -- REPLACE means to replace the suffix -- -- into the given NAME and strip off -- -- any directory name. Otherwise, -- -- the suffix is inserted if not -- -- otherwise specified by the user. -- ------------------------------------------ begin if REPLACE then --CCUR return FILENAME (NAME) & SUFFIX; --CCUR else --CCUR if EXTENSION (NAME) = "" then --CCUR return VOLUMENAME (NAME) & FILENAME (NAME) & SUFFIX & --CCUR ACCOUNT (NAME); --CCUR else --CCUR return VOLUMENAME (NAME) & FILENAME (NAME) & --CCUR EXTENSION (NAME) & ACCOUNT (NAME); --CCUR end if; --CCUR end if; --CCUR end ADD_SUFFIX; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure OPEN (FILE_NAME : in out FILE_TYPE; LONG_NAME : in STRING; SUFFIX : in STRING := OPEN_SUFFIX) is ------------------------------------------ -- This procedure opens a file with -- -- the name LONG_NAME, and the suffix -- -- SUFFIX. -- ------------------------------------------ NAME : constant STRING := ADD_SUFFIX (LONG_NAME, SUFFIX, FALSE); begin TEXT_IO.OPEN (FILE_NAME, IN_FILE, NAME); end OPEN; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure CREATE (FILE_NAME : in out FILE_TYPE; LONG_NAME : in STRING; SUFFIX : in STRING := CREATE_SUFFIX) is ------------------------------------------ -- This procedure creates a file with -- -- the name LONG_NAME and the suffix -- -- SUFFIX. -- ------------------------------------------ NAME : constant STRING := ADD_SUFFIX (LONG_NAME, SUFFIX, TRUE); STOP_PROGRAM : exception; begin declare BUFF : STRING(1..80); LEN : INTEGER; begin TEXT_IO.OPEN(FILE_NAME, OUT_FILE, NAME); TEXT_IO.CLOSE(FILE_NAME); PUT (NAME & " already exists, overwrite (y/n)?"); NEW_LINE; --CCUR GET_LINE (BUFF, LEN); if BUFF(1) = 'Y' or else BUFF(1) = 'y' then null; else raise STOP_PROGRAM; end if; exception when STOP_PROGRAM => raise; --Not handled when others => null; end; TEXT_IO.CREATE (FILE_NAME, OUT_FILE, NAME); end CREATE; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - begin -- OS_FILE_OPS initializations SET_INPUT (STANDARD_INPUT); end OS_FILE_OPS; -- body. ---------------------------------------------------------------------- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- ---------------------------------------------------------------------- ---------------------------------------------------------------------- --You shouldn't have to change this procedure: procedure GETC (FILE : in FILE_TYPE; CHAR : out CHARACTER; POSITION : in out INTEGER) is --------------------------------------------------------- -- This procedure gets one character, CHAR, from the -- -- file FILE, and also returns its position, POSITION.-- --------------------------------------------------------- begin -- GETC if END_OF_FILE (FILE) then raise END_ERROR; elsif END_OF_LINE (FILE) then CHAR := CHARACTER'VAL (13); SKIP_LINE (FILE); else GET (FILE, CHAR); end if; POSITION := POSITION + 1; exception when END_ERROR => -- Expected at end of file raise; when others => PUT_LINE ("unexpected exception in OS_DEPENDENCIES.GETC"); raise; end GETC; ---------------------------------------------------------------------- end OS_DEPENDENCIES; --:::::::::: --getoken.ada --:::::::::: -- -- -- package GETTOKEN -- -- -- ------------------------------------------------------------------------ ------------------------------------------------------------------------ with TEXT_IO; use TEXT_IO; package GETTOKEN is --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Package GETTOKEN is designed to scan a string of characters -- -- in a file, and split it up into tokens. The only available -- -- procedure is GET_TOKEN, which finds one token. The package -- -- is general enough to scan command files, but is designed to -- -- scan Ada code, specifically. -- -- -- -- All of the compiler peculiarities, editor dependencies, and -- -- filer dependencies have been moved to the OS_DEPENDENCIES -- -- package. -- -- -- -- Author: Steven E. Nameroff, C1C, USAF -- -- Date : 15 July 1983 -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- END_FILE : constant CHARACTER := CHARACTER'VAL (3); END_OF_LINE : constant CHARACTER := CHARACTER'VAL (13); BLANK_LINE : constant CHARACTER := CHARACTER'VAL (17); STRING_LENGTH : constant INTEGER := 250; subtype LENGTH_TYPE is INTEGER range 0 .. STRING_LENGTH; type CLASS_TYPE is (NUM, WORD, DELIM, COMMENT, END_OF_FILE, NONE); type STRING_RECORD is record STR_ZERO : CHARACTER := END_OF_LINE; -- ######## STR : STRING (1 .. STRING_LENGTH); LENGTH : LENGTH_TYPE := 0; CLASS : CLASS_TYPE := NONE; POSITION : LENGTH_TYPE; -- actual position in text (for comments) end record; procedure GET_TOKEN (INPUT_FILE : FILE_TYPE; TOKEN : in out STRING_RECORD); end GETTOKEN; ------------------------------------------------------------------------ ----------------------- package body GETOKEN --------------------------- ------------------------------------------------------------------------ with TEXT_IO; use TEXT_IO; with OS_DEPENDENCIES; use OS_DEPENDENCIES; package body GETTOKEN is use OS_FILE_OPS; package INT_IO is new INTEGER_IO (INTEGER); use INT_IO; type CHARACTER_TABLE is array(CHARACTER) of BOOLEAN; pragma PACK(CHARACTER_TABLE); DELIMITER : constant CHARACTER_TABLE := CHARACTER_TABLE' ('"' | ',' | '&' | ''' | '(' | ')' | '*' | '+' | '-' | '/' | ':' | ';' | '<' | '>' | '=' | '|' | '.' | BLANK_LINE => TRUE, others => FALSE); LETTER : constant CHARACTER_TABLE := CHARACTER_TABLE' ('A'..'Z' | 'a'..'z' | '_' => TRUE, others => FALSE); NUMBER : constant CHARACTER_TABLE := CHARACTER_TABLE' ('0'..'9' | '_' | '.' => TRUE, others => FALSE); CURRENT_POSITION : LENGTH_TYPE := 1; -- the location of the current -- character on the line, of the -- input file ---------------------------------------------------------------------- procedure GET_TOKEN (INPUT_FILE : FILE_TYPE; TOKEN : in out STRING_RECORD) is --------------------------------------------------------- -- This procedure is the meat of the package: it is -- -- a scanner that finds one token (TOKEN) in the -- -- input file (INPUT_FILE), making sure that it does -- -- not look ahead, or else characters will be lost. -- --------------------------------------------------------- type STATE_TYPE is (START_STATE, NUMBER_STATE, WORD_STATE, DELIMITER_STATE, FINAL_STATE); PRESENT_STATE : STATE_TYPE; -- see explanation below CHAR : CHARACTER; DOUBLE_PERIOD : constant CHARACTER := CHARACTER'VAL (1); -- see below -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure GET_CHAR (CH : in out CHARACTER; INF : FILE_TYPE) is ------------------------------------------ -- This procedure gets one character -- -- from the input file (INF). -- ------------------------------------------ begin OS_DEPENDENCIES.GETC (INF, CH, CURRENT_POSITION); if CH = END_OF_LINE then CURRENT_POSITION := 1; -- put ('.'); if TOKEN.STR_ZERO = END_OF_LINE and TOKEN.LENGTH = 0 then CH := BLANK_LINE; end if; if TOKEN.LENGTH = 0 then -- This is to tell if a comment is TOKEN.STR_ZERO := END_OF_LINE; -- on its own line (see the FORMAT end if; -- _SUPPORT package for details). end if; exception when END_ERROR => CH := CHARACTER'VAL (3); when others => PUT_LINE ("unexpected exception in GETTOKEN.GET_TOKEN.GET_CHAR"); raise; end GET_CHAR; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure ADD_ON (CH : in out CHARACTER; ST : in out STRING_RECORD; INF : FILE_TYPE) is -------------------------------------------- -- This procedure adds the character CH -- -- to the token string (ST), and calls -- -- GET_CHAR for the next character. -- -------------------------------------------- begin ST.LENGTH := ST.LENGTH + 1; ST.STR (ST.LENGTH) := CH; if CH = BLANK_LINE then CH := END_OF_LINE; else GET_CHAR (CH, INF); end if; end ADD_ON; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - begin -- GET_TOKEN CHAR := TOKEN.STR_ZERO; -- This one statement is the key to the whole -- algorithm: TOKEN.ST_ZERO holds the -- character that stopped the algorithm the -- last time it went through. Otherwise, -- that character would be lost. for I in 1 .. TOKEN.LENGTH + 1 loop TOKEN.STR (I) := ' '; end loop; TOKEN.LENGTH := 0; -- The basic algorithm is done PRESENT_STATE := START_STATE; -- by tracing through a state -- diagram. while PRESENT_STATE /= FINAL_STATE loop case PRESENT_STATE is -- In Ada one can tell whether -- a token will be a delimiter, -- number, or word, just by -- looking at the first char. when START_STATE => if DELIMITER (CHAR) then if CHAR /= BLANK_LINE then TOKEN.POSITION := CURRENT_POSITION - 1; end if; -- The position of a token is TOKEN.CLASS := DELIM; -- going to be the position of -- the first character in that -- string, which is one less -- than the current position. PRESENT_STATE := DELIMITER_STATE; ADD_ON (CHAR, TOKEN, INPUT_FILE); elsif LETTER (CHAR) then TOKEN.POSITION := CURRENT_POSITION - 1; TOKEN.CLASS := WORD; PRESENT_STATE := WORD_STATE; ADD_ON (CHAR, TOKEN, INPUT_FILE); elsif NUMBER (CHAR) then TOKEN.POSITION := CURRENT_POSITION - 1; TOKEN.CLASS := NUM; PRESENT_STATE := NUMBER_STATE; ADD_ON (CHAR, TOKEN, INPUT_FILE); elsif CHAR = END_FILE then TOKEN.CLASS := END_OF_FILE; if TOKEN.STR_ZERO = END_FILE then -- If the procedure gets to -- this raise END_ERROR; -- point (two end-of-file indi- end if; -- cators in a row), the program -- being scanned has an error in -- it somewhere, so an error is PRESENT_STATE := FINAL_STATE; -- propogated. elsif CHAR = DOUBLE_PERIOD then -- This is needed because TOKEN.STR (1 .. 2) := ".."; -- if the current token TOKEN.LENGTH := 2; -- is a number, then when GET_CHAR (CHAR, INPUT_FILE); -- it finds a period, it PRESENT_STATE := FINAL_STATE; -- needs to look ahead to -- see if the next char- -- acter is a period or -- the rest of a decimal -- number. This is the -- only time I could not -- work around the look- -- ahead requirement. else -- space or end-of-line GET_CHAR (CHAR, INPUT_FILE); end if; when WORD_STATE => -- word ::= letter {[under-score] letter|digit} if LETTER (CHAR) or else (NUMBER (CHAR) and CHAR /= '.') then ADD_ON (CHAR, TOKEN, INPUT_FILE); else -- Please note that the algorithm PRESENT_STATE := FINAL_STATE; -- does not check to make sure the end if; -- under-scores are isolated, since -- it is assumed that the program -- being scanned is syntactically -- correct. when NUMBER_STATE => -- number ::= decimal_number | based_number -- decimal_number ::= integer [.integer] [E{+|-}integer] -- integer ::= digit {[under-score] digit} -- see note above -- based_number ::= integer # GARBAGE # [E{+|-}integer] -- GARBAGE ::= anything, for all I care. if NUMBER (CHAR) then if CHAR = '.' then GET_CHAR (CHAR, INPUT_FILE); if CHAR = '.' then -- see explanation in START_STATE CHAR := DOUBLE_PERIOD; PRESENT_STATE := FINAL_STATE; else TOKEN.LENGTH := TOKEN.LENGTH + 1; TOKEN.STR (TOKEN.LENGTH) := '.'; ADD_ON (CHAR, TOKEN, INPUT_FILE); end if; else ADD_ON (CHAR, TOKEN, INPUT_FILE); end if; elsif CHAR = '#' then -- based number ADD_ON (CHAR, TOKEN, INPUT_FILE); while CHAR /= '#' loop ADD_ON (CHAR, TOKEN, INPUT_FILE); end loop; ADD_ON (CHAR, TOKEN, INPUT_FILE); elsif CHAR = 'E' then -- exponent ADD_ON (CHAR, TOKEN, INPUT_FILE); if CHAR = '+' or CHAR = '-' then ADD_ON (CHAR, TOKEN, INPUT_FILE); end if; else PRESENT_STATE := FINAL_STATE; end if; when DELIMITER_STATE => -- This part takes advantage of the PRESENT_STATE := FINAL_STATE; -- fact that any delimiter can be case TOKEN.STR (1) is -- identified by looking at the -- first two characters of the -- string -- the one that was added -- to the token already (T.STR(1)), -- and the current character. -- Again, nothing is lost. when '<' => if CHAR = '=' or CHAR = '<' or CHAR = '>' then ADD_ON (CHAR, TOKEN, INPUT_FILE); end if; when '>' => if CHAR = '=' or CHAR = '>' then ADD_ON (CHAR, TOKEN, INPUT_FILE); end if; when '=' => if CHAR = '>' then ADD_ON (CHAR, TOKEN, INPUT_FILE); end if; when '/' | ':' => if CHAR = '=' then ADD_ON (CHAR, TOKEN, INPUT_FILE); end if; when '*' => if CHAR = '*' then ADD_ON (CHAR, TOKEN, INPUT_FILE); end if; when '.' => if CHAR = '.' then ADD_ON (CHAR, TOKEN, INPUT_FILE); end if; when ''' => -- attribute indicator or character ADD_ON (CHAR, TOKEN, INPUT_FILE); if CHAR /= ''' then -- fortunately, no attributes -- have < 3 characters. PRESENT_STATE := START_STATE; end if; -- Note that I cheated a bit -- here. The algorithm will -- now go back, and recog- -- nize the token as a word, -- since the ' has been added -- to the token already. ADD_ON (CHAR, TOKEN, INPUT_FILE); when '-' => if CHAR = '-' then TOKEN.CLASS := COMMENT; CURRENT_POSITION := CURRENT_POSITION - 1; -- ######### while CHAR /= END_OF_LINE loop ADD_ON (CHAR, TOKEN, INPUT_FILE); end loop; TOKEN.STR (TOKEN.LENGTH + 1) := TOKEN.STR_ZERO; -- This tells -- the formatter if the comment is on its own line. -- See FORMAT_SUPPORT package for details. end if; when '"' => -- string ::= " {anything} " while CHAR /= '"' loop ADD_ON (CHAR, TOKEN, INPUT_FILE); end loop; ADD_ON (CHAR, TOKEN, INPUT_FILE); -- All of this garbage is to take of double quotes inside -- strings, and null strings. while CHAR = '"' loop ADD_ON (CHAR, TOKEN, INPUT_FILE); while CHAR /= '"' loop ADD_ON (CHAR, TOKEN, INPUT_FILE); end loop; ADD_ON (CHAR, TOKEN, INPUT_FILE); end loop; when others => null; end case; when FINAL_STATE => null; end case; end loop; if TOKEN.CLASS = WORD then -- Convert words to all upper-case for I in 1 .. TOKEN.LENGTH loop if CHARACTER'POS (TOKEN.STR (I)) in 97 .. 122 then TOKEN.STR (I) := CHARACTER'VAL (CHARACTER'POS (TOKEN.STR (I)) - 32); end if; end loop; end if; TOKEN.STR_ZERO := CHAR; -- see first comment in this procedure --DEBUG put_line("token => (str_zero =>" & --DEBUG integer'image(character'pos(token.str_zero)) & ", str => """ & --DEBUG token.str(1..token.length) & """, length =>" & --DEBUG length_type'image(token.length) & ", class => " & --DEBUG class_type'image(token.class) & ", position =>" & --DEBUG length_type'image(token.position) & ')' ); exception when others => PUT_LINE ("unexpected exception in GETTOKEN.GET_TOKEN"); raise; end GET_TOKEN; ---------------------------------------------------------------------- begin -- initializations null; end GETTOKEN; --:::::::::: --stubber.ada --:::::::::: -- -- -- procedure STUBBER -- -- -- ------------------------------------------------------------------------ ------------------------------------------------------------------------ with GETTOKEN; use GETTOKEN; with STUBBER_SUPPORT; use STUBBER_SUPPORT; with TEXT_IO; use TEXT_IO; with OS_DEPENDENCIES; procedure STUBBER is --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Procedure STUBBER is the main procedure for the STUBBER set -- -- of packages. It walks through the input file, one token at -- -- a time, storing specifications as it finds them, and taking -- -- care bodies, stubbing where necessary. -- -- -- -- All operating system dependencies, editor dependencies, and -- -- a few compiler dependencies can be found in the file called -- -- OS_DEPENDENCIES (that STUBBER_SUPPORT uses). -- -- -- -- PACKAGE SET DEPENDENCE: -- -- -- -- >STUBBER -- -- | | -- -- | \___>STUBBER_SUPPORT -- -- | | | -- -- | | \_______________________>OS_DEPENDENCIES -- -- | | / -- -- | \_________>GETTOKEN | -- -- \______________/ \_______/ -- -- -- -- -- -- Author: Steven E. Nameroff, C1C, USAF -- -- Date : 15 July 1983 -- -- Update: 4/28/87 J. Orost, CCUR -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- --------------------------------------------------------- -- The stubber stubs anything in a program that needs -- -- to be stubbed. It needs no assistance in deter- -- -- mining what needs to be stubbed, and there is no -- -- way of stopping it from stubbing everything that -- -- needs to be stubbed. It is imperative that the -- -- program is syntactically correct to the point of -- -- having all "if"s with matching "end if"s, etc. -- -- Failure to follow this simple and straight-forward -- -- requirement may result in the stubber producing -- -- garbage. -- --------------------------------------------------------- SPECS : DECLARATION_PTR; NEWFILE_ID : GETTOKEN.STRING_RECORD; ---------------------------------------------------------------------- function FORMAL_PARTS_MATCH (FIRST_ONE, SECOND_ONE : DECLARATION_PTR) return BOOLEAN is --------------------------------------------------------- -- This function determines if the formal parts of -- -- two declarations match. -- --------------------------------------------------------- FPM : BOOLEAN := TRUE; TEMP_1, TEMP_2 : BUFFER_PTR; begin TEMP_1 := FIRST_ONE.FORMAL_PART; TEMP_2 := SECOND_ONE.FORMAL_PART; while TEMP_1 /= null and TEMP_2 /= null loop if TEMP_1.BUFFER_STRING /= TEMP_2.BUFFER_STRING then FPM := FALSE; exit; -- Requirement 1: all of the declarations end if; -- of the one have to match that of the -- other. TEMP_1 := TEMP_1.NEXT_ONE; TEMP_2 := TEMP_2.NEXT_ONE; end loop; if TEMP_1 /= null or TEMP_2 /= null then FPM := FALSE; -- Requirment 2: both have to have the end if; -- same number of declarations in their -- formal parts. return FPM; exception when others => PUT_LINE ("Unhandled exception in STUBBER.FORMAL_PARTS_MATCH"); raise; end FORMAL_PARTS_MATCH; ---------------------------------------------------------------------- procedure DO_FORMAL_PART (CURRENT_DEC : in out DECLARATION_PTR) is --------------------------------------------------------- -- This procedure creates the formal-part buffer for -- -- a subprogram specification. -- --------------------------------------------------------- TEMP_DEC : BUFFER_PTR; PARENTHESIS_COUNT : GETTOKEN.LENGTH_TYPE := 1; -- used to keep track of -- internal parentheses TEMP_INDENT : LENGTH_TYPE := 1; -- used to indent multiple -- declarations inside the -- formal part FOUND_A_COLON : BOOLEAN := FALSE; begin -- 12 = "procedure "'LENGTH + " ("'LENGTH if CURRENT_DEC.DEC_NAME.LENGTH + 12 <= OS_DEPENDENCIES.OUTPUT_LINE_LENGTH then TEMP_INDENT := CURRENT_DEC.DEC_NAME.LENGTH + 12; end if; if TOKEN.STR (1) = '(' then CURRENT_DEC.FORMAL_PART := new BUFFER_TYPE; CURRENT_DEC.FORMAL_PART.BUFFER_STRING.STR (1 .. 2) := " ("; CURRENT_DEC.FORMAL_PART.BUFFER_STRING.LENGTH := 2; TEMP_DEC := CURRENT_DEC.FORMAL_PART; GET_ONE_TOKEN; while TOKEN.STR (1) /= ')' loop -- add tokens to the buffer string until a ")" or a ";" is found while PARENTHESIS_COUNT > 0 and TOKEN.STR (1) /= ';' loop TEMP_DEC.BUFFER_STRING.STR (TEMP_DEC.BUFFER_STRING.LENGTH + 1 .. TEMP_DEC. BUFFER_STRING.LENGTH + TOKEN.LENGTH) := TOKEN.STR (1 .. TOKEN.LENGTH); if CONVERT (TOKEN) /= NOT_KW then --Convert keywords to lower case for I in TEMP_DEC.BUFFER_STRING.LENGTH + 1 .. TEMP_DEC.BUFFER_STRING.LENGTH + TOKEN.LENGTH loop TEMP_DEC.BUFFER_STRING.STR (I) := CHARACTER'VAL( CHARACTER'POS(TEMP_DEC.BUFFER_STRING.STR (I)) - CHARACTER'POS('A') + CHARACTER'POS('a') ); end loop; end if; TEMP_DEC.BUFFER_STRING.LENGTH := TEMP_DEC.BUFFER_STRING.LENGTH + TOKEN.LENGTH; if TOKEN.LENGTH = 1 and then (TOKEN.STR (1) = ''' or else TOKEN.STR (1) = '.' or else TOKEN.STR (1) = '(') then NULL; --No space after ''', '.', or '(' else TEMP_DEC.BUFFER_STRING.LENGTH := TEMP_DEC.BUFFER_STRING.LENGTH + 1; TEMP_DEC.BUFFER_STRING.STR (TEMP_DEC.BUFFER_STRING.LENGTH) := ' '; end if; GET_ONE_TOKEN; if (TOKEN.STR (1) = ''' and then TOKEN.LENGTH > 3) or else (TOKEN.LENGTH = 1 and then (TOKEN.STR (1) = ',' or else TOKEN.STR (1) = '.')) then --No space before ',', "'ATTRIB", or '.' TEMP_DEC.BUFFER_STRING.LENGTH := TEMP_DEC.BUFFER_STRING.LENGTH - 1; elsif TOKEN.STR (1) = '(' then PARENTHESIS_COUNT := PARENTHESIS_COUNT + 1; elsif TOKEN.STR (1) = ')' then PARENTHESIS_COUNT := PARENTHESIS_COUNT - 1; --No space before ')' TEMP_DEC.BUFFER_STRING.LENGTH := TEMP_DEC.BUFFER_STRING.LENGTH - 1; elsif TOKEN.STR (1) = ':' then FOUND_A_COLON := TRUE; end if; end loop; if TOKEN.STR (1) = ';' then -- create a new buffer string TEMP_DEC.BUFFER_STRING.STR (TEMP_DEC.BUFFER_STRING.LENGTH) := ';' ; GET_ONE_TOKEN; TEMP_DEC.NEXT_ONE := new BUFFER_TYPE; TEMP_DEC := TEMP_DEC.NEXT_ONE; for I in 1 .. TEMP_INDENT loop TEMP_DEC.BUFFER_STRING.STR (I) := ' '; end loop; TEMP_DEC.BUFFER_STRING.LENGTH := TEMP_INDENT; end if; end loop; TEMP_DEC.BUFFER_STRING.LENGTH := TEMP_DEC.BUFFER_STRING.LENGTH + 1; TEMP_DEC.BUFFER_STRING.STR (TEMP_DEC.BUFFER_STRING.LENGTH) := ')'; GET_ONE_TOKEN; if CURRENT_DEC.TYPE_OF_DEC = KW_ENTRY and then (TOKEN.STR (1) = '(' or else FOUND_A_COLON = FALSE) then --Entry with discrete range --We save the discrete range in the RETURN_TYPE field --which is normally only used for FUNCTIONs CURRENT_DEC.RETURN_TYPE := CURRENT_DEC.FORMAL_PART.BUFFER_STRING; CURRENT_DEC.FORMAL_PART := null; DO_FORMAL_PART (CURRENT_DEC); --now do the real formal_part end if; end if; exception when others => PUT_LINE ("Unhandled exception in STUBBER.DO_FORMAL_PART"); raise; end DO_FORMAL_PART; ---------------------------------------------------------------------- procedure DO_SPEC (FIRST_SPEC : in out DECLARATION_PTR) is --------------------------------------------------------- -- This procedure is the meat of the STUBBER set of -- -- packages. It walks through the input file, finds -- -- all of the package/subprogram specifications and -- -- bodies, and takes appropriate action. -- --------------------------------------------------------- CURRENT_SPEC, TEMP_SPEC : DECLARATION_PTR; GOT_ONE_TOKEN : BOOLEAN := FALSE; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure CLOSE_OFF (LOSING_SPEC, MAIN_SPEC : in out DECLARATION_PTR) is ------------------------------------------ -- This procedure eliminates one spe- -- -- cification (LOSING_SPEC) from a -- -- linked list of specifications -- -- (MAIN_SPEC). -- ------------------------------------------ TEMP_DEC : DECLARATION_PTR; begin if LOSING_SPEC = MAIN_SPEC then -- if the LOSING_SPEC is the first MAIN_SPEC := MAIN_SPEC.NEXT_DEC; -- spec in the linked list, then -- the pointer to the first spec now -- points to the second spec. else -- Otherwise, TEMP_DEC TEMP_DEC := MAIN_SPEC; -- goes through the while TEMP_DEC.NEXT_DEC /= LOSING_SPEC loop -- list until it finds TEMP_DEC := TEMP_DEC.NEXT_DEC; -- the spec that points end loop; -- to LOSING_SPEC, TEMP_DEC.NEXT_DEC := LOSING_SPEC.NEXT_DEC; -- at which point, it is end if; -- changed so that it now -- points to what LOSING_ -- SPEC pointed to. exception when others => PUT_LINE ("Unhandled exception in STUBBER.DO_SPEC.CLOSE_OFF"); raise; end CLOSE_OFF; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure FOUND_WORD_PACKAGE is ------------------------------------------ -- This procedure, called when the re- -- -- served word "package" is found, -- -- determines if the structure found -- -- is a package body or package spec., -- -- and takes appropriate action. -- ------------------------------------------ DUMMY : BUFFER_PTR; STRING_DUMMY : STRING_RECORD; IS_POSITION : LENGTH_TYPE; begin CURRENT_SPEC.TYPE_OF_DEC := KW_PACKAGE; CURRENT_SPEC.PRIOR_TOKENS := SAVED_TOKENS; GET_ONE_TOKEN; if CONVERT (TOKEN) = KW_BODY then GET_ONE_TOKEN; -- id CURRENT_SPEC.DEC_NAME := TOKEN; GET_ONE_TOKEN; -- 'IS' if CONVERT (TOKEN) /= KW_SEPARATE then -- found a package body NEW_LINE; PUT ("Found package body "); PUT (CURRENT_SPEC.DEC_NAME.STR (1 .. CURRENT_SPEC.DEC_NAME.LENGTH) ); TEMP_SPEC := FIRST_SPEC; -- search for a matching specification (EXACT match) while TEMP_SPEC.TYPE_OF_DEC /= CURRENT_SPEC.TYPE_OF_DEC or else TEMP_SPEC.DEC_NAME.STR /= CURRENT_SPEC.DEC_NAME.STR loop TEMP_SPEC := TEMP_SPEC.NEXT_DEC; end loop; if TEMP_SPEC = CURRENT_SPEC then -- no matching spec. PUT (" (no matching spec.)"); TEMP_SPEC.INTERNAL_DECS := new DECLARATION_BUFF; else -- found matching spec. PUT (" (with matching spec.)"); CLOSE_OFF (TEMP_SPEC, FIRST_SPEC); -- the spec is no -- longer saved end if; DO_SPEC (TEMP_SPEC.INTERNAL_DECS); STUB (TEMP_SPEC.INTERNAL_DECS); if CONVERT (TOKEN) = KW_BEGIN then GET_PAST_END; -- get through initializations end if; end if; -- when a package body is found, there is no reason -- to save anything, because all work has been done -- on it, so a new storage buffer is not made. else CURRENT_SPEC.DEC_NAME := TOKEN; GET_ONE_TOKEN; -- 'IS' | 'RENAMES' if CONVERT (TOKEN) = KW_IS then IS_POSITION := TOKEN.POSITION; DUMMY := SAVED_TOKENS; --flush out saved tokens GET_ONE_TOKEN; if CONVERT (TOKEN) /= KW_NEW then -- found package spec. if SAVED_TOKENS_HEAD /= null and then SAVED_TOKENS_HEAD.BUFFER_STRING.CLASS = COMMENT and then SAVED_TOKENS_HEAD.BUFFER_STRING.POSITION > IS_POSITION then --Grab following comment CURRENT_SPEC.FOLLOW_TOKENS := SAVED_TOKENS; end if; NEW_LINE; PUT ("Found package spec. "); PUT (CURRENT_SPEC.DEC_NAME.STR (1 .. CURRENT_SPEC.DEC_NAME.LENGTH)); CURRENT_SPEC.INTERNAL_DECS := new DECLARATION_BUFF; -- recursive call to save internal specifications DO_SPEC (CURRENT_SPEC.INTERNAL_DECS); -- end [<IDENTIFIER>] ; while TOKEN.STR (1) /= ';' loop GET_ONE_TOKEN; end loop; if CURRENT_SPEC.FOLLOW_TOKENS = null then CURRENT_SPEC.FOLLOW_TOKENS := new BUFFER_TYPE'( STRING_DUMMY, SAVED_TOKENS); else CURRENT_SPEC.FOLLOW_TOKENS.NEXT_ONE := SAVED_TOKENS; end if; CURRENT_SPEC.NEXT_DEC := new DECLARATION_BUFF; CURRENT_SPEC := CURRENT_SPEC.NEXT_DEC; end if; end if; end if; exception when others => PUT_LINE ("Unhandled exception in " & "STUBBER.DO_SPEC.FOUND_WORD_PACKAGE"); raise; end FOUND_WORD_PACKAGE; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure FOUND_SUBPROGRAM is ------------------------------------------ -- This procedure, called when the re- -- -- served word "procedure", "function" -- -- or "entry" is found, it -- -- determines if the structure is a -- -- subprogram specification or body, -- -- and takes appropriate action. -- ------------------------------------------ DUMMY : BUFFER_PTR; SEMI_POSITION : LENGTH_TYPE; --Append STR to end of REC procedure APPEND (REC : in out STRING_RECORD; STR : in STRING) is begin REC.STR (REC.LENGTH + 1 .. REC.LENGTH + STR'LENGTH) := STR; REC.LENGTH := REC.LENGTH + STR'LENGTH; end APPEND; begin -- store everything, whether it'll be used or not CURRENT_SPEC.TYPE_OF_DEC := CONVERT (TOKEN); CURRENT_SPEC.PRIOR_TOKENS := SAVED_TOKENS; GET_ONE_TOKEN; -- id CURRENT_SPEC.DEC_NAME := TOKEN; GET_ONE_TOKEN; DO_FORMAL_PART (CURRENT_SPEC); -- process (...) if CURRENT_SPEC.TYPE_OF_DEC = KW_FUNCTION then GET_ONE_TOKEN; -- id CURRENT_SPEC.RETURN_TYPE := TOKEN; GET_ONE_TOKEN; while TOKEN.STR (1) = '.' loop --Handle xxx.yyy.zzz APPEND (CURRENT_SPEC.RETURN_TYPE, "."); GET_ONE_TOKEN; APPEND (CURRENT_SPEC.RETURN_TYPE, TOKEN.STR (1 .. TOKEN.LENGTH)); GET_ONE_TOKEN; end loop; end if; if TOKEN.STR (1) = ';' then -- found subprogram spec. SEMI_POSITION := TOKEN.POSITION; if TOKEN.STR_ZERO /= GETTOKEN.END_FILE then DUMMY := SAVED_TOKENS; --clear saved tokens GET_ONE_TOKEN; if SAVED_TOKENS_HEAD /= null and then SAVED_TOKENS_HEAD.BUFFER_STRING.CLASS = COMMENT and then SAVED_TOKENS_HEAD.BUFFER_STRING.POSITION > SEMI_POSITION then --Grab following comment CURRENT_SPEC.FOLLOW_TOKENS := SAVED_TOKENS; end if; GOT_ONE_TOKEN := TRUE; end if; CURRENT_SPEC.NEXT_DEC := new DECLARATION_BUFF; -- nothing to do CURRENT_SPEC := CURRENT_SPEC.NEXT_DEC; -- but move on elsif CONVERT (TOKEN) = KW_IS then GET_ONE_TOKEN; if CONVERT (TOKEN) /= KW_NEW and CONVERT (TOKEN) /= KW_SEPARATE then -- found subprogram body NEW_LINE; PUT ("Found subprogram body "); PUT (CURRENT_SPEC.DEC_NAME.STR (1 .. CURRENT_SPEC.DEC_NAME.LENGTH)); -- check for matching spec. TEMP_SPEC := FIRST_SPEC; while TEMP_SPEC.TYPE_OF_DEC /= CURRENT_SPEC.TYPE_OF_DEC or else TEMP_SPEC.DEC_NAME.STR /= CURRENT_SPEC.DEC_NAME.STR or else TEMP_SPEC.RETURN_TYPE /= CURRENT_SPEC.RETURN_TYPE or else not FORMAL_PARTS_MATCH (TEMP_SPEC, CURRENT_SPEC) loop TEMP_SPEC := TEMP_SPEC.NEXT_DEC; end loop; if TEMP_SPEC = CURRENT_SPEC then PUT (" (no matching spec)"); else PUT (" (with matching spec)"); CLOSE_OFF (TEMP_SPEC, FIRST_SPEC); end if; CURRENT_SPEC.INTERNAL_DECS := new DECLARATION_BUFF; DO_SPEC (CURRENT_SPEC.INTERNAL_DECS); STUB (CURRENT_SPEC.INTERNAL_DECS); GET_PAST_END; -- get through the subprogram seq-of-stmts. end if; end if; -- procedure bodies are never needed for future -- reference and cannot be stubbed, so a new -- storage location is not made. exception when others => PUT_LINE ("Unhandled exception in " & "STUBBER.DO_SPEC.FOUND_SUBPROGRAM"); raise; end FOUND_SUBPROGRAM; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure FOUND_INTERFACE is ------------------------------------------ -- This procedure, called when the -- -- sequence "pragma INTERFACE" is -- -- found. It eliminates the -- -- corresponding subprogram -- -- specification. -- ------------------------------------------ MATCHES : INTEGER := 0; begin GET_ONE_TOKEN; -- '(' SAVE_ONE_TOKEN; GET_ONE_TOKEN; -- language SAVE_ONE_TOKEN; GET_ONE_TOKEN; -- ',' SAVE_ONE_TOKEN; GET_ONE_TOKEN; --id SAVE_ONE_TOKEN; NEW_LINE; PUT ("Found pragma interface "); PUT (TOKEN.STR (1 .. TOKEN.LENGTH)); -- check for matching spec. TEMP_SPEC := FIRST_SPEC; while TEMP_SPEC.NEXT_DEC /= null loop if TEMP_SPEC.DEC_NAME.STR = TOKEN.STR and then (TEMP_SPEC.TYPE_OF_DEC = KW_PROCEDURE or else TEMP_SPEC.TYPE_OF_DEC = KW_FUNCTION) then CLOSE_OFF (TEMP_SPEC, FIRST_SPEC); MATCHES := MATCHES + 1; end if; TEMP_SPEC := TEMP_SPEC.NEXT_DEC; end loop; if MATCHES = 0 then PUT (" (no matching spec)"); elsif MATCHES = 1 then PUT (" (with matching spec)"); else PUT (" (with matching specs)"); end if; GET_ONE_TOKEN; -- ')' SAVE_ONE_TOKEN; GET_ONE_TOKEN; -- ';' SAVE_ONE_TOKEN; exception when others => PUT_LINE ("Unhandled exception in " & "STUBBER.DO_SPEC.FOUND_INTERFACE"); raise; end FOUND_INTERFACE; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure FOUND_TASK is ------------------------------------------ -- This procedure, called when the re- -- -- served word "task" is found, -- -- determines if the structure found -- -- is a task body or task spec., -- -- and takes appropriate action. -- ------------------------------------------ DUMMY : BUFFER_PTR; STRING_DUMMY : STRING_RECORD; IS_POSITION : LENGTH_TYPE; begin CURRENT_SPEC.TYPE_OF_DEC := KW_TASK; CURRENT_SPEC.PRIOR_TOKENS := SAVED_TOKENS; GET_ONE_TOKEN; if CONVERT (TOKEN) = KW_TYPE then GET_ONE_TOKEN; -- id end if; if CONVERT (TOKEN) = KW_BODY then GET_ONE_TOKEN; -- id CURRENT_SPEC.DEC_NAME := TOKEN; GET_ONE_TOKEN; -- 'IS' if CONVERT (TOKEN) /= KW_SEPARATE then -- found a task body NEW_LINE; PUT ("Found task body "); PUT (CURRENT_SPEC.DEC_NAME.STR (1 .. CURRENT_SPEC.DEC_NAME.LENGTH) ); TEMP_SPEC := FIRST_SPEC; -- search for a matching specification (EXACT match) while TEMP_SPEC.TYPE_OF_DEC /= CURRENT_SPEC.TYPE_OF_DEC or else TEMP_SPEC.DEC_NAME.STR /= CURRENT_SPEC.DEC_NAME.STR loop TEMP_SPEC := TEMP_SPEC.NEXT_DEC; end loop; if TEMP_SPEC = CURRENT_SPEC then -- no matching spec. PUT (" (no matching spec.)"); TEMP_SPEC.INTERNAL_DECS := new DECLARATION_BUFF; else -- found matching spec. PUT (" (with matching spec.)"); CLOSE_OFF (TEMP_SPEC, FIRST_SPEC); -- the spec is no -- longer saved end if; DO_SPEC (TEMP_SPEC.INTERNAL_DECS); STUB (TEMP_SPEC.INTERNAL_DECS); if CONVERT (TOKEN) = KW_BEGIN then GET_PAST_END; -- get through initializations end if; end if; -- when a task body is found, there is no reason -- to save anything, because all work has been done -- on it, so a new storage buffer is not made. else CURRENT_SPEC.DEC_NAME := TOKEN; GET_ONE_TOKEN; -- 'IS' | ';' IS_POSITION := TOKEN.POSITION; if CONVERT (TOKEN) = KW_IS then DUMMY := SAVED_TOKENS; --clear saved tokens GET_ONE_TOKEN; if SAVED_TOKENS_HEAD /= null and then SAVED_TOKENS_HEAD.BUFFER_STRING.CLASS = COMMENT and then SAVED_TOKENS_HEAD.BUFFER_STRING.POSITION > IS_POSITION then --Grab following comment CURRENT_SPEC.FOLLOW_TOKENS := SAVED_TOKENS; end if; NEW_LINE; PUT ("Found task spec. "); PUT (CURRENT_SPEC.DEC_NAME.STR (1 .. CURRENT_SPEC.DEC_NAME.LENGTH)); CURRENT_SPEC.INTERNAL_DECS := new DECLARATION_BUFF; -- recursive call to save internal specifications DO_SPEC (CURRENT_SPEC.INTERNAL_DECS); -- end [<IDENTIFIER>] ; while TOKEN.STR (1) /= ';' loop GET_ONE_TOKEN; end loop; if CURRENT_SPEC.FOLLOW_TOKENS = null then CURRENT_SPEC.FOLLOW_TOKENS := new BUFFER_TYPE'( STRING_DUMMY, SAVED_TOKENS); else CURRENT_SPEC.FOLLOW_TOKENS.NEXT_ONE := SAVED_TOKENS; end if; CURRENT_SPEC.NEXT_DEC := new DECLARATION_BUFF; CURRENT_SPEC := CURRENT_SPEC.NEXT_DEC; elsif TOKEN.STR (1) = ';' then if TOKEN.STR_ZERO /= GETTOKEN.END_FILE then DUMMY := SAVED_TOKENS; --clear saved tokens GET_ONE_TOKEN; if SAVED_TOKENS_HEAD /= null and then SAVED_TOKENS_HEAD.BUFFER_STRING.CLASS = COMMENT and then SAVED_TOKENS_HEAD.BUFFER_STRING.POSITION > IS_POSITION then --Grab following comment CURRENT_SPEC.FOLLOW_TOKENS := SAVED_TOKENS; end if; GOT_ONE_TOKEN := TRUE; end if; NEW_LINE; PUT ("Found task spec. "); PUT (CURRENT_SPEC.DEC_NAME.STR (1 .. CURRENT_SPEC.DEC_NAME.LENGTH)); CURRENT_SPEC.NEXT_DEC := new DECLARATION_BUFF; CURRENT_SPEC := CURRENT_SPEC.NEXT_DEC; end if; end if; exception when others => PUT_LINE ("Unhandled exception in " & "STUBBER.DO_SPEC.FOUND_TASK"); raise; end FOUND_TASK; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - begin -- DO_SPEC CURRENT_SPEC := FIRST_SPEC; while CURRENT_SPEC.NEXT_DEC /= null loop -- see main procedure CURRENT_SPEC := CURRENT_SPEC.NEXT_DEC; -- for explanation of end loop; -- the basic logic while TOKEN.STR_ZERO /= GETTOKEN.END_FILE and CONVERT (TOKEN) /= KW_END and CONVERT (TOKEN) /= KW_BEGIN loop case CONVERT (TOKEN) is when KW_PACKAGE => FOUND_WORD_PACKAGE; when KW_PROCEDURE | KW_FUNCTION | KW_ENTRY => FOUND_SUBPROGRAM; when KW_TASK => FOUND_TASK; when KW_PRAGMA => SAVE_ONE_TOKEN; GET_ONE_TOKEN; SAVE_ONE_TOKEN; if TOKEN.STR (1 .. TOKEN.LENGTH) = "INTERFACE" then FOUND_INTERFACE; end if; when KW_TYPE => -- find records, and get past the "end record", -- so that the "end" of a record does not get -- me out of this procedure SAVE_ONE_TOKEN; while CONVERT (TOKEN) /= KW_IS and TOKEN.STR (1) /= ';' loop GET_ONE_TOKEN; SAVE_ONE_TOKEN; if TOKEN.STR (1) = '(' then while TOKEN.STR (1) /= ')' loop GET_ONE_TOKEN; SAVE_ONE_TOKEN; end loop; end if; end loop; if CONVERT (TOKEN) = KW_IS then GET_ONE_TOKEN; SAVE_ONE_TOKEN; if CONVERT (TOKEN) = KW_RECORD then GET_PAST_END; end if; end if; when KW_FOR => -- find representation records, and get past -- the "end record" SAVE_ONE_TOKEN; while CONVERT (TOKEN) /= KW_USE loop GET_ONE_TOKEN; SAVE_ONE_TOKEN; end loop; GET_ONE_TOKEN; SAVE_ONE_TOKEN; if CONVERT (TOKEN) = KW_RECORD then GET_PAST_END; end if; when KW_WITH => --Handle "with function" SAVE_ONE_TOKEN; --and "with procedure" GET_ONE_TOKEN; --by ignoring the token following "with" SAVE_ONE_TOKEN; when others => SAVE_ONE_TOKEN; end case; exit when TOKEN.STR_ZERO = GETTOKEN.END_FILE; if not GOT_ONE_TOKEN then GET_ONE_TOKEN; -- anything else GOT_ONE_TOKEN := FALSE; end if; end loop; CURRENT_SPEC := null; exception when others => PUT_LINE ("Unhandled exception in STUBBER.DO_SPEC"); raise; end DO_SPEC; ---------------------------------------------------------------------- begin -- stubber INITIALIZE (NEWFILE_ID); GET_ONE_TOKEN; SPECS := new DECLARATION_BUFF; -- At this point, let me try to explain the system I used. Every- -- thing revolves around the data structure, "DECLARATION_BUFF" (I -- hope that you are now grabbing the package "STUBBER_SUPPORT", -- which contains the type declaration, so that you can follow what -- I am about to say). All declaration buffers have two pointers -- to other declaration buffers: INTERNAL_DECS points to the first -- of those declarations which are one lexical level inside the dec- -- laration being looked at. In other words, if a given declaration -- buffer is for a package specification, INTERNAL_DECS points to the -- first package/subprogram specification found within that package -- specification. NEXT_DEC points to the next declaration on the same -- lexical level as the given declaration. PRIOR_TOKENS points to a -- list of comments and declarative tokens that precede this -- declaration. They are output as comments. FOLLOW_TOKENS points to a -- list of comments and declarative tokens, the first being the comment -- immediately following the ";" or "is", and the rest are preceding the -- "end". RETURN_TYPE contains the function return type for function, -- or the entry_family declaration for entries. Still confused? Well, -- let's walk through an example. Since package STUBBER_SUPPORT is already -- right there in front of you we'll use it. When the word "package" -- is found by procedure DO_SPEC, it calls FOUND_WORD_PACKAGE. This -- procedure will determine that it found a package specification, and -- get ready to accept specifications inside package STUBBER_SUPPORT -- by creating a new declaration storage buffer, and pointing to it with -- its INTERNAL_DECS buffer. Then DO_SPEC will be called recursively, -- to start a new set (horizontally speaking) of specifications. -- When it gets to the function CONVERT declaration, it saves it by -- creating a new storage location, pointing to it with its NEXT_DEC -- pointer, and moving to the new storage buffer. When DO_SPEC reaches -- the word "end", it will leave the procedure, which will take us back -- to where it was called in FOUND_PACKAGE, which, in turn, will save -- everything by creating a new storage buffer, pointing to it with its -- NEXT_DEC pointer, and moving to the new storage buffer. still con- -- fused? Reread this paragraph. STILL confused? Tough. -- SAVE_ONE_TOKEN is used to collect the PRIOR_TOKENS and FOLLOW_TOKENS. DO_SPEC (SPECS); -- the main procedure just initiates the STUB (SPECS); -- pointers, calls DO_SPEC, and calls STUB -- to stub anything left. DUMP (NEWFILE_ID); exception when others => PUT_LINE ("Unhandled exception in STUBBER"); raise; end STUBBER; --:::::::::: --stubsup.ada --:::::::::: -- package STUBBER_SUPPORT -- -- -- ------------------------------------------------------------------------ ------------------------------------------------------------------------ with TEXT_IO; use TEXT_IO; with GETTOKEN; use GETTOKEN; package STUBBER_SUPPORT is --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Package STUBBER_SUPPORT is the support package for package -- -- STUBBER (You wouldn't have guessed that by the title, now, -- -- would you?). It contains the procedures that initialize & -- -- finalize things and the procedures that do the interaction -- -- with the input_file. -- -- -- -- All of the peculiarities that are due to the editor or the -- -- filer have been moved to the OS_DEPENDENCIES package. -- -- -- -- Author: Steven E. Nameroff, C1C, USAF -- -- Date : 15 July 1983 -- -- Update: 4/28/87, Joseph M. Orost, Concurrent Computer Corp. -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- type KEY_WORDS is (KW_ABORT , KW_ABS , KW_ACCEPT , KW_ACCESS , KW_ALL , KW_AND , KW_ARRAY , KW_AT , KW_BEGIN , KW_BODY , KW_CASE , KW_CONSTANT , KW_DECLARE , KW_DELAY , KW_DELTA , KW_DIGITS , KW_DO , KW_ELSE , KW_ELSIF , KW_END , KW_PRIVATE , KW_EXCEPTION, KW_EXIT , KW_FOR , KW_PRAGMA , KW_GENERIC , KW_GOTO , KW_IF , KW_IN , KW_IS , KW_LIMITED , KW_LOOP , KW_MOD , KW_NEW , KW_NOT , KW_NULL , KW_OF , KW_OR , KW_OTHERS , KW_OUT , KW_PACKAGE , KW_FUNCTION , KW_PROCEDURE, KW_ENTRY , KW_TASK , KW_RANGE , KW_RECORD , KW_REM , KW_RENAMES , KW_RETURN , KW_REVERSE , KW_SELECT , KW_SEPARATE , KW_SUBTYPE , KW_RAISE , KW_TERMINATE, KW_THEN , KW_TYPE , KW_USE , KW_WHEN , KW_WHILE , KW_WITH , KW_XOR , NOT_KW ); type BUFFER_TYPE; type BUFFER_PTR is access BUFFER_TYPE; type BUFFER_TYPE is record BUFFER_STRING : GETTOKEN.STRING_RECORD; NEXT_ONE : BUFFER_PTR := null; end record; subtype DEC_TYPE is KEY_WORDS range KW_PACKAGE .. KW_TASK; type DECLARATION_BUFF; type DECLARATION_PTR is access DECLARATION_BUFF; type DECLARATION_BUFF is record TYPE_OF_DEC : DEC_TYPE; DEC_NAME : STRING_RECORD; FORMAL_PART : BUFFER_PTR := null; -- not used for packages RETURN_TYPE : STRING_RECORD; -- used only for functions INTERNAL_DECS : DECLARATION_PTR := null; NEXT_DEC : DECLARATION_PTR := null; -- I explain all of this PRIOR_TOKENS : BUFFER_PTR := null; FOLLOW_TOKENS : BUFFER_PTR := null; end record; -- nonsense in STUBBER. TOKEN : STRING_RECORD; INPUT_FILE : FILE_TYPE; OUTPUT_FILE : FILE_TYPE; function CONVERT (STR1 : STRING_RECORD) return KEY_WORDS; procedure GET_ONE_TOKEN; SAVED_TOKENS_HEAD : BUFFER_PTR := null; SAVED_TOKENS_TAIL : BUFFER_PTR := null; procedure SAVE_ONE_TOKEN; function SAVED_TOKENS return BUFFER_PTR; procedure INITIALIZE (OUTFILE_ID : out STRING_RECORD); procedure DUMP (FILE_ID : STRING_RECORD); procedure STUB (SPECIFICATION : DECLARATION_PTR); procedure GET_PAST_END; end STUBBER_SUPPORT; ------------------------------------------------------------------------ ------------------- package body STUBBER_SUPPORT ----------------------- ------------------------------------------------------------------------ with OS_DEPENDENCIES; use OS_DEPENDENCIES; package body STUBBER_SUPPORT is use OS_FILE_OPS; package INT_IO is new INTEGER_IO (INTEGER); use INT_IO; type KWP is access STRING; KW : array (KEY_WORDS) of KWP; FIRST_TIME_THROUGH_STUB : BOOLEAN; OUTER_DECLARATION : DECLARATION_PTR; REAL_INDENT, INDENT : INTEGER; SPACES : constant STRING(1..256) := (1..256 => ' '); ---------------------------------------------------------------------- procedure GET_ONE_TOKEN is --------------------------------------------------------- -- This procedure gets one token from the input file, -- -- making sure that it is not a comment or a blank -- -- line (which would mix up the stubber itself). -- --------------------------------------------------------- begin GET_TOKEN (INPUT_FILE, TOKEN); -- not much to it; just a call to -- GET_TOKEN until its not a comment -- or a blank line while TOKEN.CLASS = COMMENT or TOKEN.STR (1) = GETTOKEN.BLANK_LINE loop SAVE_ONE_TOKEN; GET_TOKEN (INPUT_FILE, TOKEN); end loop; end GET_ONE_TOKEN; procedure SAVE_ONE_TOKEN is TOKEN_BUFFER : BUFFER_PTR := new BUFFER_TYPE'(TOKEN, null); begin if SAVED_TOKENS_TAIL = null then SAVED_TOKENS_TAIL := TOKEN_BUFFER; SAVED_TOKENS_HEAD := TOKEN_BUFFER; else SAVED_TOKENS_TAIL.NEXT_ONE := TOKEN_BUFFER; SAVED_TOKENS_TAIL := TOKEN_BUFFER; end if; end SAVE_ONE_TOKEN; ---------------------------------------------------------------------- function SAVED_TOKENS return BUFFER_PTR is RESULT : BUFFER_PTR := SAVED_TOKENS_HEAD; begin SAVED_TOKENS_HEAD := null; SAVED_TOKENS_TAIL := null; return RESULT; end SAVED_TOKENS; ---------------------------------------------------------------------- procedure INITIALIZE (OUTFILE_ID : out STRING_RECORD) is --------------------------------------------------------- -- This procedure sets everything up for the STUBBER -- -- procedure. It saves the name of the input file -- -- for future reference (OUTFILE_ID). -- --------------------------------------------------------- begin NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; PUT_LINE (" STUBBER"); NEW_LINE; PUT_LINE ("This program stubs anything in your program that needs to be"); PUT_LINE ("stubbed. You need do nothing to tell the stubber what needs"); PUT_LINE ("to be stubbed; it figures it out by itself. It is imperative"); PUT_LINE ("that the program being stubbed is syntactically correct, at"); PUT_LINE ("least to the point that each 'if' has and 'end if', etc. If"); PUT_LINE ("this is not the case, then the stubber will self-destruct or"); PUT_LINE ("worse than that, it will miss-stub your program. This stub-"); PUT_LINE ("ber will also keep you informed as to where it is and what's"); PUT_LINE ("being stubbed."); NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; NEW_LINE; loop begin declare FILENAME : constant STRING := GET_FILENAME; begin begin OS_FILE_OPS.OPEN (INPUT_FILE, FILENAME); exception when NAME_ERROR => PUT_LINE ("Cannot open " & FILENAME); raise; end; OS_FILE_OPS.CREATE (OUTPUT_FILE, FILENAME); declare NAME : constant STRING := TEXT_IO.NAME (OUTPUT_FILE); begin OUTFILE_ID.LENGTH := NAME'LENGTH; OUTFILE_ID.STR (NAME'RANGE) := NAME; end; end; exit; exception when NAME_ERROR => null; end; end loop; TOKEN.LENGTH := STRING_LENGTH - 1; -- this will force a blank-out TOKEN.STR_ZERO := GETTOKEN.END_OF_LINE; exception when others => PUT_LINE ("Unhandled exception in STUBBER_SUPPORT.INITIALIZE"); raise; end INITIALIZE; ---------------------------------------------------------------------- procedure DUMP (FILE_ID : STRING_RECORD) is --------------------------------------------------------- -- This procedure finishes everything up. It is the -- -- epitome of making procedures for the sole purpose -- -- of modularization. -- --------------------------------------------------------- begin NEW_LINE; NEW_LINE; PUT ("Your stubbed version is under "); PUT_LINE (FILE_ID.STR (1 .. FILE_ID.LENGTH)); CLOSE (OUTPUT_FILE); end DUMP; ---------------------------------------------------------------------- procedure STUB (SPECIFICATION : DECLARATION_PTR) is --------------------------------------------------------- -- This procedure is the actual stub generator. Given -- -- a specification, or set of specifications, as de- -- -- termined by SPECIFICATION, the procedure will -- -- generate the appropriate stub. -- --------------------------------------------------------- CURRENT_DEC : DECLARATION_PTR; CURRENT_BUFF : BUFFER_PTR; RETURN_TYPE_SAVE : STRING_RECORD; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure WRITE_ID (FILE : FILE_TYPE; ID : in STRING_RECORD) is ------------------------------------------ -- This procedure writes out an iden- -- -- tifier when it is in a string. It -- -- is necessary for the case of over- -- -- loaded operators, that have a '"' -- -- as part of the name, so this has to -- -- be taken care of. -- ------------------------------------------ begin if ID.STR (1) = '"' then PUT (FILE, '"'); PUT (FILE, ID.STR (1 .. ID.LENGTH)); PUT (FILE, '"'); else PUT (FILE, ID.STR (1 .. ID.LENGTH)); end if; end WRITE_ID; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure PUT_SPACES (FILE : FILE_TYPE; AMOUNT : INTEGER) is begin PUT (FILE, SPACES(1 .. AMOUNT)); end PUT_SPACES; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure PUT_INDENT (FILE : FILE_TYPE; ITEM : STRING := "") is begin PUT_SPACES (FILE, INDENT); PUT (FILE, ITEM); end PUT_INDENT; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - function IS_ROOM (FILE : FILE_TYPE; LENGTH : NATURAL) return BOOLEAN is begin if INTEGER (COL (FILE)) + LENGTH > OUTPUT_LINE_LENGTH then NEW_LINE (FILE); if INDENT + LENGTH <= OUTPUT_LINE_LENGTH then PUT_INDENT (FILE); end if; return FALSE; end if; return TRUE; end IS_ROOM; procedure MAKE_ROOM (FILE : FILE_TYPE; LENGTH : NATURAL) is DUMMY : BOOLEAN; begin DUMMY := IS_ROOM (FILE, LENGTH); end MAKE_ROOM; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure DO_PRIOR_TOKENS (CUR : in out BUFFER_PTR) is NEW_LINE_COL : INTEGER; begin while CUR /= null loop if CUR.BUFFER_STRING.CLASS = COMMENT then PUT_SPACES (OUTPUT_FILE, CUR.BUFFER_STRING.POSITION - 1); PUT_LINE (OUTPUT_FILE, CUR.BUFFER_STRING.STR (1 .. CUR.BUFFER_STRING.LENGTH)); elsif CUR.BUFFER_STRING.STR (1) = GETTOKEN.BLANK_LINE then NEW_LINE (OUTPUT_FILE); else NEW_LINE_COL := 0; PUT (OUTPUT_FILE, "--"); while CUR.BUFFER_STRING.STR (1) /= GETTOKEN.END_OF_LINE loop if CUR.BUFFER_STRING.POSITION + 2 + CUR.BUFFER_STRING.LENGTH - 1 - NEW_LINE_COL > OUTPUT_LINE_LENGTH then NEW_LINE_COL := CUR.BUFFER_STRING.POSITION - 2; NEW_LINE (OUTPUT_FILE); PUT (OUTPUT_FILE, "--"); end if; PUT_SPACES (OUTPUT_FILE, CUR.BUFFER_STRING.POSITION + 2 - (INTEGER(COL(OUTPUT_FILE))+NEW_LINE_COL)); if CUR.BUFFER_STRING.CLASS = WORD and then CONVERT (CUR.BUFFER_STRING) /= NOT_KW then --Output keywords in lower case for I in 1..CUR.BUFFER_STRING.LENGTH loop PUT (OUTPUT_FILE, CHARACTER'VAL( CHARACTER'POS(CUR.BUFFER_STRING.STR (I)) - CHARACTER'POS('A') + CHARACTER'POS('a'))); end loop; else PUT (OUTPUT_FILE, CUR.BUFFER_STRING.STR (1 .. CUR.BUFFER_STRING.LENGTH)); end if; exit when CUR.BUFFER_STRING.STR_ZERO = GETTOKEN.END_OF_LINE; CUR := CUR.NEXT_ONE; exit when CUR = null; if CUR.BUFFER_STRING.STR (1) = GETTOKEN.BLANK_LINE then NEW_LINE (OUTPUT_FILE); exit; end if; end loop; NEW_LINE (OUTPUT_FILE); end if; exit when CUR = null; CUR := CUR.NEXT_ONE; exit when CUR = null; end loop; end DO_PRIOR_TOKENS; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure DO_FOLLOW_TOKEN (SPECIFICATION : DECLARATION_PTR) is CUR : BUFFER_PTR := SPECIFICATION.FOLLOW_TOKENS; COUNT : INTEGER; begin if CUR /= null and then CUR.BUFFER_STRING.LENGTH /= 0 then COUNT := CUR.BUFFER_STRING.POSITION - INTEGER (COL (OUTPUT_FILE)); if COUNT <= 0 then COUNT := 1; end if; if COUNT + CUR.BUFFER_STRING.LENGTH <= OUTPUT_LINE_LENGTH then PUT_SPACES (OUTPUT_FILE, COUNT); else PUT (OUTPUT_FILE, ' '); MAKE_ROOM (OUTPUT_FILE, CUR.BUFFER_STRING.LENGTH); end if; PUT_LINE (OUTPUT_FILE, CUR.BUFFER_STRING.STR (1 .. CUR.BUFFER_STRING.LENGTH)); SPECIFICATION.FOLLOW_TOKENS := SPECIFICATION.FOLLOW_TOKENS.NEXT_ONE; else NEW_LINE (OUTPUT_FILE); end if; end DO_FOLLOW_TOKEN; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure ENTER_INDENT is begin REAL_INDENT := REAL_INDENT + INDENT_AMOUNT; if REAL_INDENT <= INDENT_LIMIT then INDENT := REAL_INDENT; end if; end ENTER_INDENT; procedure EXIT_INDENT is begin REAL_INDENT := REAL_INDENT - INDENT_AMOUNT; if REAL_INDENT >= 0 and then REAL_INDENT <= INDENT_LIMIT then INDENT := REAL_INDENT; end if; end EXIT_INDENT; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - function SPLIT_RANGE (CURRENT_DEC : DECLARATION_PTR) return BOOLEAN is --The discrete_range for a task entry is of the form: -- subtype_indication | T'RANGE | -- simple_expression .. simple_expression --The only form we handle here is integer .. integer --Any other form is not handled and the function returns FALSE --For forms that are handled, a duplicate entry is created for --each entry in the discrete range. NEXT : DECLARATION_PTR := CURRENT_DEC.NEXT_DEC; TEMP, PREV : DECLARATION_PTR; START1, START2, STOP1, STOP2 : INTEGER; type STATE_TYPE is (INITIAL_STATE, AFTER_OPEN, AFTER_DOT, AFTER_RANGE); STATE : STATE_TYPE := INITIAL_STATE; C : CHARACTER; PAREN : INTEGER := 0; LB, UB, LAST : INTEGER; FAMILY_MEMBER : STRING_RECORD; ATTRIBUTE : INTEGER := 0; begin if CURRENT_DEC.RETURN_TYPE.CLASS = GETTOKEN.NUM then return TRUE; --Already split! end if; for I in 1 .. CURRENT_DEC.RETURN_TYPE.LENGTH loop C := CURRENT_DEC.RETURN_TYPE.STR (I); if C = '(' then PAREN := PAREN + 1; elsif C = ')' then PAREN := PAREN - 1; if PAREN = 0 then if STATE = AFTER_RANGE then STOP2 := I - 1; exit; --All OK so far! elsif STATE = AFTER_OPEN then if ATTRIBUTE /= 0 then --T'RANGE CURRENT_DEC.RETURN_TYPE.STR (ATTRIBUTE+1 .. ATTRIBUTE+5) := "FIRST"; else CURRENT_DEC.RETURN_TYPE.STR (I .. I + 6) := "'FIRST)"; CURRENT_DEC.RETURN_TYPE.LENGTH := I + 6; end if; return FALSE; --Not handled, but will compile! else return FALSE; --Not handled, user must edit end if; end if; end if; case STATE is when INITIAL_STATE => if C = '(' then STATE := AFTER_OPEN; end if; START1 := I + 1; when AFTER_OPEN => if PAREN = 1 then if C = '.' then STATE := AFTER_DOT; elsif C = ''' then ATTRIBUTE := I; end if; end if; when AFTER_DOT => if C = '.' then STATE := AFTER_RANGE; STOP1 := I - 2; START2 := I + 1; else STATE := AFTER_OPEN; end if; when AFTER_RANGE => null; end case; end loop; if STATE /= AFTER_RANGE or else PAREN /= 0 then return FALSE; end if; GET (CURRENT_DEC.RETURN_TYPE.STR (START1 .. STOP1), LB, LAST); for I in LAST+1 .. STOP1 loop if CURRENT_DEC.RETURN_TYPE.STR (I) /= ' ' then return FALSE; end if; end loop; GET (CURRENT_DEC.RETURN_TYPE.STR (START2 .. STOP2), UB, LAST); for I in LAST+1 .. STOP2 loop if CURRENT_DEC.RETURN_TYPE.STR (I) /= ' ' then return FALSE; end if; end loop; if LB > UB then return FALSE; --Null range not handled end if; PREV := null; for I in LB .. UB loop declare S : constant STRING := INTEGER'IMAGE(I); begin FAMILY_MEMBER.STR (1 .. 2) := " ("; FAMILY_MEMBER.STR (3 .. S'LAST + 2) := S; FAMILY_MEMBER.STR (S'LAST + 3 .. S'LAST + 4) := " )"; FAMILY_MEMBER.LENGTH := S'LAST + 4; FAMILY_MEMBER.CLASS := GETTOKEN.NUM; end; if PREV = null then CURRENT_DEC.RETURN_TYPE := FAMILY_MEMBER; PREV := CURRENT_DEC; else TEMP := new DECLARATION_BUFF'(CURRENT_DEC.TYPE_OF_DEC, CURRENT_DEC.DEC_NAME, CURRENT_DEC.FORMAL_PART, FAMILY_MEMBER, CURRENT_DEC.INTERNAL_DECS, null, --NEXT_DEC null, --PRIOR_TOKENS CURRENT_DEC.FOLLOW_TOKENS); PREV.NEXT_DEC := TEMP; PREV := TEMP; end if; end loop; PREV.NEXT_DEC := NEXT; return TRUE; exception when others => return FALSE; end SPLIT_RANGE; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - begin -- STUB CURRENT_DEC := SPECIFICATION; if FIRST_TIME_THROUGH_STUB then REAL_INDENT := 0; INDENT := 0; FIRST_TIME_THROUGH_STUB := FALSE; else NEW_LINE (OUTPUT_FILE); NEW_LINE (OUTPUT_FILE); ENTER_INDENT; end if; while CURRENT_DEC.NEXT_DEC /= null loop NEW_LINE; PUT ("Now stubbing "); PUT (CURRENT_DEC.DEC_NAME.STR (1 .. CURRENT_DEC.DEC_NAME.LENGTH)); DO_PRIOR_TOKENS (CURRENT_DEC.PRIOR_TOKENS); if REAL_INDENT = 0 then OUTER_DECLARATION := CURRENT_DEC; PUT_LINE (OUTPUT_FILE, "with TEXT_IO; use TEXT_IO;"); end if; case CURRENT_DEC.TYPE_OF_DEC is when KW_PROCEDURE => PUT_INDENT (OUTPUT_FILE, "procedure "); when KW_FUNCTION => PUT_INDENT (OUTPUT_FILE, "function "); when KW_PACKAGE => PUT_INDENT (OUTPUT_FILE, "package body "); when KW_TASK => PUT_INDENT (OUTPUT_FILE, "task body "); when KW_ENTRY => PUT_INDENT (OUTPUT_FILE, "accept "); end case; MAKE_ROOM (OUTPUT_FILE, CURRENT_DEC.DEC_NAME.LENGTH); PUT (OUTPUT_FILE, CURRENT_DEC.DEC_NAME.STR (1 .. CURRENT_DEC.DEC_NAME.LENGTH)); if CURRENT_DEC.TYPE_OF_DEC = KW_PACKAGE then -- stubbing a package PUT (OUTPUT_FILE, " is"); -- body DO_FOLLOW_TOKEN (CURRENT_DEC); -- output optional comment STUB (CURRENT_DEC.INTERNAL_DECS); -- recursive call to handle the -- internal specifications DO_PRIOR_TOKENS (CURRENT_DEC.FOLLOW_TOKENS); NEW_LINE (OUTPUT_FILE); PUT_INDENT (OUTPUT_FILE, "end "); PUT (OUTPUT_FILE, CURRENT_DEC.DEC_NAME.STR (1 .. CURRENT_DEC.DEC_NAME.LENGTH)); PUT_LINE (OUTPUT_FILE, "; -- body"); elsif CURRENT_DEC.TYPE_OF_DEC = KW_TASK then -- stubbing a task PUT (OUTPUT_FILE, " is"); -- body DO_FOLLOW_TOKEN (CURRENT_DEC); -- output optional comment PUT_INDENT (OUTPUT_FILE, "begin"); NEW_LINE (OUTPUT_FILE); if CURRENT_DEC.INTERNAL_DECS /= null then ENTER_INDENT; PUT_INDENT (OUTPUT_FILE, "loop"); NEW_LINE (OUTPUT_FILE); ENTER_INDENT; PUT_INDENT (OUTPUT_FILE, "select"); STUB (CURRENT_DEC.INTERNAL_DECS); -- recursive call to handle the -- internal specifications PUT_INDENT (OUTPUT_FILE, "end select;"); NEW_LINE (OUTPUT_FILE); EXIT_INDENT; PUT_INDENT (OUTPUT_FILE, "end loop;"); NEW_LINE (OUTPUT_FILE); EXIT_INDENT; else PUT_SPACES (OUTPUT_FILE, INDENT_AMOUNT); PUT_INDENT (OUTPUT_FILE, "PUT_LINE (""Body stub for "); if OUTER_DECLARATION /= CURRENT_DEC then if INTEGER (COL (OUTPUT_FILE)) + OUTER_DECLARATION.DEC_NAME.LENGTH > OUTPUT_LINE_LENGTH then PUT_LINE (OUTPUT_FILE, """ &"); if OUTER_DECLARATION.DEC_NAME.LENGTH + INDENT + 10 + INDENT_AMOUNT <= OUTPUT_LINE_LENGTH then PUT_SPACES (OUTPUT_FILE, INDENT + 10 + INDENT_AMOUNT); end if; PUT (OUTPUT_FILE, '"'); end if; PUT (OUTPUT_FILE, OUTER_DECLARATION.DEC_NAME.STR (1 .. OUTER_DECLARATION.DEC_NAME.LENGTH)); PUT (OUTPUT_FILE, '.'); end if; if INTEGER (COL (OUTPUT_FILE)) + CURRENT_DEC.DEC_NAME.LENGTH > OUTPUT_LINE_LENGTH then PUT_LINE (OUTPUT_FILE, """ &"); if CURRENT_DEC.DEC_NAME.LENGTH + INDENT + 10 + INDENT_AMOUNT <= OUTPUT_LINE_LENGTH then PUT_SPACES (OUTPUT_FILE, INDENT + 10 + INDENT_AMOUNT); end if; PUT (OUTPUT_FILE, '"'); end if; WRITE_ID (OUTPUT_FILE, CURRENT_DEC.DEC_NAME); PUT_LINE (OUTPUT_FILE, """);"); end if; DO_PRIOR_TOKENS (CURRENT_DEC.FOLLOW_TOKENS); NEW_LINE (OUTPUT_FILE); PUT_INDENT (OUTPUT_FILE, "end "); PUT (OUTPUT_FILE, CURRENT_DEC.DEC_NAME.STR (1 .. CURRENT_DEC.DEC_NAME.LENGTH)); PUT_LINE (OUTPUT_FILE, "; -- body"); else --procedure/function/entry if CURRENT_DEC.TYPE_OF_DEC = KW_ENTRY and then CURRENT_DEC.RETURN_TYPE.LENGTH /= 0 then --Entry family RETURN_TYPE_SAVE := CURRENT_DEC.RETURN_TYPE; if not SPLIT_RANGE (CURRENT_DEC) then NEW_LINE; PUT ("Can't handle entry family without simple range"); if 46 + 5 + CURRENT_DEC.DEC_NAME.LENGTH + RETURN_TYPE_SAVE.LENGTH <= OUTPUT_LINE_LENGTH then PUT (' '); else NEW_LINE; end if; PUT ("for "); PUT (CURRENT_DEC.DEC_NAME.STR (1 .. CURRENT_DEC.DEC_NAME.LENGTH)); PUT_LINE (RETURN_TYPE_SAVE.STR (1 .. RETURN_TYPE_SAVE.LENGTH)); PUT ("You must edit the task body"); end if; MAKE_ROOM (OUTPUT_FILE, CURRENT_DEC.RETURN_TYPE.LENGTH); PUT (OUTPUT_FILE, CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH)); end if; CURRENT_BUFF := CURRENT_DEC.FORMAL_PART; while CURRENT_BUFF /= null loop if CURRENT_BUFF.BUFFER_STRING.LENGTH > OUTPUT_LINE_LENGTH then declare I : INTEGER := 1; J : INTEGER; begin while I <= CURRENT_BUFF.BUFFER_STRING.LENGTH loop J := I; while J <= CURRENT_BUFF.BUFFER_STRING.LENGTH and then CURRENT_BUFF.BUFFER_STRING.STR (J) /= ' ' loop J := J + 1; end loop; if IS_ROOM (OUTPUT_FILE, (J - I)) and then I /= 1 then PUT (OUTPUT_FILE, ' '); end if; PUT (OUTPUT_FILE, CURRENT_BUFF.BUFFER_STRING.STR (I .. J-1)); I := J + 1; end loop; end; else MAKE_ROOM(OUTPUT_FILE, CURRENT_BUFF.BUFFER_STRING.LENGTH); PUT (OUTPUT_FILE, CURRENT_BUFF.BUFFER_STRING.STR (1 .. CURRENT_BUFF.BUFFER_STRING.LENGTH)); end if; CURRENT_BUFF := CURRENT_BUFF.NEXT_ONE; if CURRENT_BUFF /= null then NEW_LINE (OUTPUT_FILE); PUT_INDENT (OUTPUT_FILE); if CURRENT_DEC.TYPE_OF_DEC = KW_ENTRY then -- Space over past entry family index (if any) PUT_SPACES (OUTPUT_FILE, CURRENT_DEC.RETURN_TYPE.LENGTH); end if; end if; end loop; if CURRENT_DEC.TYPE_OF_DEC = KW_FUNCTION then MAKE_ROOM (OUTPUT_FILE, 8); PUT (OUTPUT_FILE, " return "); MAKE_ROOM (OUTPUT_FILE, CURRENT_DEC.RETURN_TYPE.LENGTH); PUT (OUTPUT_FILE, CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH)); end if; MAKE_ROOM (OUTPUT_FILE, 3); if CURRENT_DEC.TYPE_OF_DEC = KW_ENTRY then PUT (OUTPUT_FILE, " do"); else PUT (OUTPUT_FILE, " is"); end if; DO_FOLLOW_TOKEN (CURRENT_DEC); NEW_LINE (OUTPUT_FILE); if CURRENT_DEC.TYPE_OF_DEC = KW_FUNCTION then -- all functions PUT_SPACES (OUTPUT_FILE, INDENT_AMOUNT); PUT_INDENT (OUTPUT_FILE, "DUMMY : "); -- require a return MAKE_ROOM (OUTPUT_FILE, CURRENT_DEC.RETURN_TYPE.LENGTH); PUT (OUTPUT_FILE, CURRENT_DEC.RETURN_TYPE.STR -- statement to (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH)); -- compile, so to -- An attempt to put in default values for STANDARD types -- Ought to be done for derived types and composites of STANDARD if CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH) = "INTEGER" or else CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH) = "SHORT_INTEGER" or else CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH) = "LONG_INTEGER" or else CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH) = "TINY_INTEGER" then PUT (OUTPUT_FILE, " := 1"); elsif CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH) = "FLOAT" or else CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH) = "SHORT_FLOAT" or else CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH) = "LONG_FLOAT" then PUT (OUTPUT_FILE, " := 1.0"); elsif CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH) = "BOOLEAN" then PUT (OUTPUT_FILE, " := TRUE"); elsif CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH) = "STRING" then PUT (OUTPUT_FILE, "(1..6) := ""STRING"""); elsif CURRENT_DEC.RETURN_TYPE.STR (1 .. CURRENT_DEC.RETURN_TYPE.LENGTH) = "CHARACTER" then PUT (OUTPUT_FILE, " := 'C'"); end if; PUT (OUTPUT_FILE, ';'); -- guarantee that NEW_LINE (OUTPUT_FILE); -- all types are NEW_LINE (OUTPUT_FILE); -- accounted for, a end if; -- dummy variable is -- created and returned. -- One must note that one -- cannot run this func- -- tion, since dummy is -- never initialized (and -- for the same reasons it -- was created, couldn't be), -- but it will compile. if CURRENT_DEC.TYPE_OF_DEC /= KW_ENTRY then PUT_INDENT (OUTPUT_FILE, "begin"); if CURRENT_DEC.DEC_NAME.LENGTH + INTEGER (COL (OUTPUT_FILE)) + 13 < OUTPUT_LINE_LENGTH then PUT (OUTPUT_FILE, " -- "); PUT_LINE (OUTPUT_FILE, CURRENT_DEC.DEC_NAME.STR (1 .. CURRENT_DEC.DEC_NAME.LENGTH)); else NEW_LINE (OUTPUT_FILE); end if; end if; PUT_SPACES (OUTPUT_FILE, INDENT_AMOUNT); PUT_INDENT (OUTPUT_FILE, "PUT_LINE (""Body stub for "); if OUTER_DECLARATION /= CURRENT_DEC then if INTEGER (COL (OUTPUT_FILE)) + OUTER_DECLARATION.DEC_NAME.LENGTH > OUTPUT_LINE_LENGTH then PUT_LINE (OUTPUT_FILE, """ &"); if OUTER_DECLARATION.DEC_NAME.LENGTH + INDENT + 10 + INDENT_AMOUNT <= OUTPUT_LINE_LENGTH then PUT_SPACES (OUTPUT_FILE, INDENT + 10 + INDENT_AMOUNT); end if; PUT (OUTPUT_FILE, '"'); end if; PUT (OUTPUT_FILE, OUTER_DECLARATION.DEC_NAME.STR (1 .. OUTER_DECLARATION.DEC_NAME.LENGTH)); PUT (OUTPUT_FILE, '.'); end if; if INTEGER (COL (OUTPUT_FILE)) + CURRENT_DEC.DEC_NAME.LENGTH > OUTPUT_LINE_LENGTH then PUT_LINE (OUTPUT_FILE, """ &"); if CURRENT_DEC.DEC_NAME.LENGTH + INDENT + 10 + INDENT_AMOUNT <= OUTPUT_LINE_LENGTH then PUT_SPACES (OUTPUT_FILE, INDENT + 10 + INDENT_AMOUNT); end if; PUT (OUTPUT_FILE, '"'); end if; WRITE_ID (OUTPUT_FILE, CURRENT_DEC.DEC_NAME); PUT_LINE (OUTPUT_FILE, """);"); if CURRENT_DEC.TYPE_OF_DEC = KW_FUNCTION then PUT_SPACES (OUTPUT_FILE, INDENT_AMOUNT); PUT_INDENT (OUTPUT_FILE, "return DUMMY;"); NEW_LINE (OUTPUT_FILE); end if; NEW_LINE (OUTPUT_FILE); if GENERATE_EXCEPTION_PART and then CURRENT_DEC.TYPE_OF_DEC /= KW_ENTRY then PUT_INDENT (OUTPUT_FILE, "exception"); NEW_LINE (OUTPUT_FILE); PUT_SPACES (OUTPUT_FILE, INDENT_AMOUNT); PUT_INDENT (OUTPUT_FILE, "when others =>"); NEW_LINE (OUTPUT_FILE); PUT_SPACES (OUTPUT_FILE, INDENT_AMOUNT * 2); PUT_INDENT (OUTPUT_FILE, "PUT_LINE (""Unhandled exception in "); if OUTER_DECLARATION /= CURRENT_DEC then if INTEGER (COL (OUTPUT_FILE)) + OUTER_DECLARATION.DEC_NAME.LENGTH > OUTPUT_LINE_LENGTH then PUT_LINE (OUTPUT_FILE, """ &"); if OUTER_DECLARATION.DEC_NAME.LENGTH + INDENT + 10 + INDENT_AMOUNT * 2 <= OUTPUT_LINE_LENGTH then PUT_SPACES (OUTPUT_FILE, INDENT + 10 + INDENT_AMOUNT * 2); end if; PUT (OUTPUT_FILE, '"'); end if; PUT (OUTPUT_FILE, OUTER_DECLARATION.DEC_NAME.STR (1 .. OUTER_DECLARATION.DEC_NAME.LENGTH)); PUT (OUTPUT_FILE, '.'); end if; if INTEGER (COL (OUTPUT_FILE)) + CURRENT_DEC.DEC_NAME.LENGTH > OUTPUT_LINE_LENGTH then PUT_LINE (OUTPUT_FILE, """ &"); if CURRENT_DEC.DEC_NAME.LENGTH + INDENT + 10 + INDENT_AMOUNT * 2 <= OUTPUT_LINE_LENGTH then PUT_SPACES (OUTPUT_FILE, INDENT + 10 + INDENT_AMOUNT * 2); end if; PUT (OUTPUT_FILE, '"'); end if; WRITE_ID (OUTPUT_FILE, CURRENT_DEC.DEC_NAME); PUT_LINE (OUTPUT_FILE, """);"); PUT_SPACES (OUTPUT_FILE, INDENT_AMOUNT * 2); PUT_INDENT (OUTPUT_FILE, "raise;"); NEW_LINE (OUTPUT_FILE); end if; PUT_INDENT (OUTPUT_FILE, "end "); MAKE_ROOM (OUTPUT_FILE, CURRENT_DEC.DEC_NAME.LENGTH + 1); PUT (OUTPUT_FILE, CURRENT_DEC.DEC_NAME.STR (1 .. CURRENT_DEC.DEC_NAME.LENGTH)); PUT (OUTPUT_FILE, ';'); NEW_LINE (OUTPUT_FILE); if CURRENT_DEC.TYPE_OF_DEC = KW_ENTRY and then CURRENT_DEC.NEXT_DEC /= null then EXIT_INDENT; PUT_INDENT (OUTPUT_FILE, "or"); ENTER_INDENT; if CURRENT_DEC.NEXT_DEC.NEXT_DEC = null then NEW_LINE (OUTPUT_FILE); NEW_LINE (OUTPUT_FILE); PUT_INDENT (OUTPUT_FILE, "terminate;"); end if; end if; end if; CURRENT_DEC := CURRENT_DEC.NEXT_DEC; NEW_LINE (OUTPUT_FILE); NEW_LINE (OUTPUT_FILE); end loop; EXIT_INDENT; exception when others => PUT_LINE ("Unhandled exception in STUBBER_SUPPORT.STUB"); raise; end STUB; ---------------------------------------------------------------------- procedure GET_PAST_END is --------------------------------------------------------- -- This procedure is designed to skip past tokens -- -- until it finds the word "end". However, it must -- -- find the "end" that goes with the token that -- -- forced the procedure call in the first place. So -- -- when it comes upon a word that will also have an -- -- "end" associated with it, it must get past that -- -- one, too. -- --------------------------------------------------------- begin GET_ONE_TOKEN; SAVE_ONE_TOKEN; while CONVERT (TOKEN) /= KW_END loop case CONVERT (TOKEN) is when KW_ACCEPT | KW_BEGIN | KW_CASE | KW_IF | KW_LOOP | KW_RECORD => GET_PAST_END; -- This is a rather ingenious method of getting -- through the body of a subprogram, record, or -- whatever. Every time a word is found that has -- and "end" associated with it, the procedure -- calls itself. when others => null; end case; GET_ONE_TOKEN; SAVE_ONE_TOKEN; end loop; GET_ONE_TOKEN; -- This last GET_ONE is SAVE_ONE_TOKEN; -- to eliminate the -- possibility of the -- procedure finding the -- "if" of an "end if", etc. end GET_PAST_END; ---------------------------------------------------------------------- procedure LOAD_KEY_WORDS is begin for I in KEY_WORDS loop KW (I) := new STRING'(KEY_WORDS'IMAGE (I)); end loop; end LOAD_KEY_WORDS; ---------------------------------------------------------------------- function CONVERT (STR1 : STRING_RECORD) return KEY_WORDS is --| Overview --| --| This perfect hash algorithm taken from --| "A Perfect Hash Function for Ada Reserved Words" --| by David Wolverton, published in Ada Letters Jul-Aug 1984 --| subtype HASH_RANGE is INTEGER; subtype HASH_IDENTIFIER_SUBRANGE is HASH_RANGE range 0 .. 70; type XLATE_ARRAY is array (CHARACTER) of HASH_RANGE; XLATE : constant XLATE_ARRAY := XLATE_ARRAY' ('A' => 0 , 'B' => 49 , 'C' => 0 , 'D' => - 7 , 'E' => - 20, 'F' => 18 , 'G' => - 2 , 'H' => - 38, 'I' => 33 , 'J' => 0 , 'K' => - 9 , 'L' => 9 , 'M' => 29 , 'N' => - 9 , 'O' => 6 , 'P' => 26 , 'Q' => 0 , 'R' => 8 , 'S' => 1 , 'T' => 1 , 'U' => - 9 , 'V' => 0 , 'W' => 56 , 'X' => - 28, 'Y' => 11 , 'Z' => 0 , others => 0); type HASH_TABLE_ARRAY is array (HASH_IDENTIFIER_SUBRANGE) of KEY_WORDS; --| Mapping from hash value into the token values. HASH_TABLE : constant HASH_TABLE_ARRAY := HASH_TABLE_ARRAY' (40 => KW_ABORT , 6 => KW_ABS , 37 => KW_ACCEPT , 43 => KW_ACCESS , 34 => KW_ALL , 22 => KW_AND , 16 => KW_ARRAY , 3 => KW_AT , 61 => KW_BEGIN , 70 => KW_BODY , 20 => KW_CASE , 35 => KW_CONSTANT , 14 => KW_DECLARE , 9 => KW_DELAY , 36 => KW_DELTA , 38 => KW_DIGITS , 7 => KW_DO , 0 => KW_ELSE , 19 => KW_ELSIF , 2 => KW_END , 30 => KW_ENTRY , 8 => KW_EXCEPTION , 1 => KW_EXIT , 57 => KW_FOR , 45 => KW_FUNCTION , 21 => KW_GENERIC , 46 => KW_GOTO , 69 => KW_IF , 42 => KW_IN , 52 => KW_IS , 17 => KW_LIMITED , 67 => KW_LOOP , 53 => KW_MOD , 58 => KW_NEW , 23 => KW_NOT , 26 => KW_NULL , 54 => KW_OF , 44 => KW_OR , 47 => KW_OTHERS , 50 => KW_OUT , 25 => KW_PACKAGE , 56 => KW_PRAGMA , 51 => KW_PRIVATE , 49 => KW_PROCEDURE, 29 => KW_RAISE , 5 => KW_RANGE , 41 => KW_RECORD , 48 => KW_REM , 24 => KW_RENAMES , 39 => KW_RETURN , 31 => KW_REVERSE , 12 => KW_SELECT , 27 => KW_SEPARATE , 18 => KW_SUBTYPE , 32 => KW_TASK , 28 => KW_TERMINATE, 4 => KW_THEN , 15 => KW_TYPE , 10 => KW_USE , 59 => KW_WHEN , 63 => KW_WHILE , 60 => KW_WITH , 11 => KW_XOR , others => NOT_KW ); IN_IDENTIFIER : STRING renames STR1.STR (1 .. STR1.LENGTH); OUT_TOKEN_VALUE : KEY_WORDS; LENGTH : HASH_RANGE := IN_IDENTIFIER'LENGTH; --| Length of string FIRST : HASH_RANGE := IN_IDENTIFIER'FIRST; --| Lower bound FIRST_CHAR, LAST_CHAR : CHARACTER; --| First and last characters SECOND_TO_LAST_CHAR : CHARACTER; --| Second to last character SECOND_TO_LAST : HASH_RANGE; --| Alphabetic position of 2nd to last char. HASH_VALUE : HASH_RANGE; --| Perfect hash value. TOKEN_VALUE : KEY_WORDS; begin -- Assume In_Identifier is a plain identifier. OUT_TOKEN_VALUE := NOT_KW; if (LENGTH <= 1) or else (LENGTH >= 10) then return NOT_KW; -- Couldn't be a reserved word. else FIRST_CHAR := IN_IDENTIFIER (FIRST); LAST_CHAR := IN_IDENTIFIER ((FIRST + LENGTH) - 1); SECOND_TO_LAST_CHAR := IN_IDENTIFIER ((FIRST + LENGTH) - 2); SECOND_TO_LAST := CHARACTER'POS (SECOND_TO_LAST_CHAR) - CHARACTER'POS ('A'); HASH_VALUE := XLATE (FIRST_CHAR) + XLATE (LAST_CHAR) + 2 * SECOND_TO_LAST + LENGTH; end if; if HASH_VALUE in HASH_IDENTIFIER_SUBRANGE then -- index and see if it matches a reserved word value. -- if so, then compare the string to the reserved word text. TOKEN_VALUE := HASH_TABLE (HASH_VALUE); if TOKEN_VALUE /= NOT_KW then declare IM : KWP := KW (TOKEN_VALUE); begin if (IN_IDENTIFIER = IM.all (4 .. IM.all'LAST)) then OUT_TOKEN_VALUE := TOKEN_VALUE; end if; end; end if; end if; return OUT_TOKEN_VALUE; end CONVERT; ---------------------------------------------------------------------- begin -- initializations LOAD_KEY_WORDS; FIRST_TIME_THROUGH_STUB := TRUE; end STUBBER_SUPPORT; --:::::::::: --stubtest.spc --:::::::::: --Comments before --the package spec with calendar; package stubtest is --Comment on package STUBTEST --Comment before procedure a procedure a; --Comment on procedure A decl function b(arg1, arg2 : integer) return string; type c is record d : calendar.time; end record; --Comment before the generic package f generic type e is private; with procedure gen1 is <>; with procedure gen2; --This requires special care (looks like a spec)! package f is function g return c; procedure h(arg1 : e; arg2 : OUT float; arg3 : IN OUT integer); function i return e; end f; --Comment before function j function j return boolean; function k return integer; --comment on function k decl function l return short_integer; function "and" (left, right : integer) return integer; --comment on "and" --Comment before task m task m; task type n; --comment on n type not_handled is range 1..2; type no_good is array(not_handled) of boolean; task type o is --comment on task type o entry p; --comment on entry p entry q(arg1, arg2 : integer); entry r(1..3)(arg1 : integer; arg2 : OUT float); entry s(not_handled); entry t(no_good'range)(arg1 : integer); --comment before end of task type o end o; function u (arg1, arg2 : IN calendar.time) return calendar.time; procedure v (arg1, arg2 : IN integer := integer'first; arg3 : IN float := 16#1_000.0#E0; arg4 : string := ""; arg5 : character := '''; arg6 : character := character'val(character'pos(''')); arg7 : integer := (integer'last mod (2**4)); arg8 : string := (1 => 'a', 2 => '''); arg9 : string := """inside"""; arga : IN OUT integer); procedure interfaced; function interfaced return boolean; --this comment should be suppressed type very_long_type_name_for_the_function_result_type is new integer; type very_long_type_name_for_the_arguments is new integer; function this_is_a_very_very_long_function_name_see_if_it_is_handled_properly( long_argument_name_1, long_argument_name_2, long_argument_name_3, long_argument_name_4 : IN integer; long_argument_name_5, long_argument_name_6, long_argument_name_7, long_argument_name_8 : IN very_long_type_name_for_the_arguments) return very_long_type_name_for_the_function_result_type; --sure is a long function private --comment in private part pragma interface(assembler, interfaced); end stubtest; --comments before the procedure finish procedure finish; --:::::::::: --stubtest.bdy --:::::::::: --Comments before --the package spec --with CALENDAR; with TEXT_IO; use TEXT_IO; package body STUBTEST is --Comment on package STUBTEST procedure A is --Comment on procedure A decl begin -- A PUT_LINE ("Body stub for STUBTEST.A"); exception when others => PUT_LINE ("Unhandled exception in STUBTEST.A"); raise; end A; function B (ARG1, ARG2 : INTEGER) return STRING is DUMMY : STRING(1..6) := "STRING"; begin -- B PUT_LINE ("Body stub for STUBTEST.B"); return DUMMY; exception when others => PUT_LINE ("Unhandled exception in STUBTEST.B"); raise; end B; -- type C is record -- D : CALENDAR.TIME; -- end record; --Comment before the generic package f -- generic -- type E is private; -- with procedure GEN1 is <>; -- with procedure GEN2; --This requires special care (looks like a spec)! package body F is function G return C is DUMMY : C; begin -- G PUT_LINE ("Body stub for STUBTEST.G"); return DUMMY; exception when others => PUT_LINE ("Unhandled exception in STUBTEST.G"); raise; end G; procedure H (ARG1 : E; ARG2 : out FLOAT; ARG3 : in out INTEGER) is begin -- H PUT_LINE ("Body stub for STUBTEST.H"); exception when others => PUT_LINE ("Unhandled exception in STUBTEST.H"); raise; end H; function I return E is DUMMY : E; begin -- I PUT_LINE ("Body stub for STUBTEST.I"); return DUMMY; exception when others => PUT_LINE ("Unhandled exception in STUBTEST.I"); raise; end I; -- end F; -- body --Comment before function j function J return BOOLEAN is DUMMY : BOOLEAN := TRUE; begin -- J PUT_LINE ("Body stub for STUBTEST.J"); return DUMMY; exception when others => PUT_LINE ("Unhandled exception in STUBTEST.J"); raise; end J; function K return INTEGER is --comment on function k decl DUMMY : INTEGER := 1; begin -- K PUT_LINE ("Body stub for STUBTEST.K"); return DUMMY; exception when others => PUT_LINE ("Unhandled exception in STUBTEST.K"); raise; end K; function L return SHORT_INTEGER is DUMMY : SHORT_INTEGER := 1; begin -- L PUT_LINE ("Body stub for STUBTEST.L"); return DUMMY; exception when others => PUT_LINE ("Unhandled exception in STUBTEST.L"); raise; end L; function "and" (LEFT, RIGHT : INTEGER) return INTEGER is --comment on "and" DUMMY : INTEGER := 1; begin -- "and" PUT_LINE ("Body stub for STUBTEST.""and"""); return DUMMY; exception when others => PUT_LINE ("Unhandled exception in STUBTEST.""and"""); raise; end "and"; task body M is begin PUT_LINE ("Body stub for STUBTEST.M"); end M; -- body task body N is --comment on n begin PUT_LINE ("Body stub for STUBTEST.N"); end N; -- body -- type NOT_HANDLED is range 1..2; -- type NO_GOOD is array(NOT_HANDLED) of BOOLEAN; task body O is --comment on task type o begin loop select accept P do --comment on entry p PUT_LINE ("Body stub for STUBTEST.P"); end P; or accept Q (ARG1, ARG2 : INTEGER) do PUT_LINE ("Body stub for STUBTEST.Q"); end Q; or accept R ( 1 ) (ARG1 : INTEGER; ARG2 : out FLOAT) do PUT_LINE ("Body stub for STUBTEST.R"); end R; or accept R ( 2 ) (ARG1 : INTEGER; ARG2 : out FLOAT) do PUT_LINE ("Body stub for STUBTEST.R"); end R; or accept R ( 3 ) (ARG1 : INTEGER; ARG2 : out FLOAT) do PUT_LINE ("Body stub for STUBTEST.R"); end R; or accept S (NOT_HANDLED'FIRST) do PUT_LINE ("Body stub for STUBTEST.S"); end S; or accept T (NO_GOOD'FIRST) (ARG1 : INTEGER) do PUT_LINE ("Body stub for STUBTEST.T"); end T; or terminate; end select; end loop; --comment before end of task type o end O; -- body function U (ARG1, ARG2 : in CALENDAR.TIME) return CALENDAR.TIME is DUMMY : CALENDAR.TIME; begin -- U PUT_LINE ("Body stub for STUBTEST.U"); return DUMMY; exception when others => PUT_LINE ("Unhandled exception in STUBTEST.U"); raise; end U; procedure V (ARG1, ARG2 : in INTEGER := INTEGER'FIRST; ARG3 : in FLOAT := 16#1_000.0#E0; ARG4 : STRING := ""; ARG5 : CHARACTER := '''; ARG6 : CHARACTER := CHARACTER'VAL (CHARACTER'POS (''')); ARG7 : INTEGER := (INTEGER'LAST mod (2 ** 4)); ARG8 : STRING := (1 => 'a', 2 => '''); ARG9 : STRING := """inside"""; ARGA : in out INTEGER) is begin -- V PUT_LINE ("Body stub for STUBTEST.V"); exception when others => PUT_LINE ("Unhandled exception in STUBTEST.V"); raise; end V; -- type VERY_LONG_TYPE_NAME_FOR_THE_FUNCTION_RESULT_TYPE is new -- INTEGER; -- type VERY_LONG_TYPE_NAME_FOR_THE_ARGUMENTS is -- new -- INTEGER; function THIS_IS_A_VERY_VERY_LONG_FUNCTION_NAME_SEE_IF_IT_IS_HANDLED_PROPERLY (LONG_ARGUMENT_NAME_1, LONG_ARGUMENT_NAME_2, LONG_ARGUMENT_NAME_3, LONG_ARGUMENT_NAME_4 : in INTEGER; LONG_ARGUMENT_NAME_5, LONG_ARGUMENT_NAME_6, LONG_ARGUMENT_NAME_7, LONG_ARGUMENT_NAME_8 : in VERY_LONG_TYPE_NAME_FOR_THE_ARGUMENTS) return VERY_LONG_TYPE_NAME_FOR_THE_FUNCTION_RESULT_TYPE is --sure is a long function DUMMY : VERY_LONG_TYPE_NAME_FOR_THE_FUNCTION_RESULT_TYPE; begin PUT_LINE ("Body stub for STUBTEST." & "THIS_IS_A_VERY_VERY_LONG_FUNCTION_NAME_SEE_IF_IT_IS_HANDLED_PROPERLY"); return DUMMY; exception when others => PUT_LINE ("Unhandled exception in STUBTEST." & "THIS_IS_A_VERY_VERY_LONG_FUNCTION_NAME_SEE_IF_IT_IS_HANDLED_PROPERLY"); raise; end THIS_IS_A_VERY_VERY_LONG_FUNCTION_NAME_SEE_IF_IT_IS_HANDLED_PROPERLY; --private --comment in private part -- pragma INTERFACE(ASSEMBLER, INTERFACED); end STUBTEST; -- body --comments before the procedure finish with TEXT_IO; use TEXT_IO; procedure FINISH is begin -- FINISH PUT_LINE ("Body stub for FINISH"); exception when others => PUT_LINE ("Unhandled exception in FINISH"); raise; end FINISH;