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 / stubber.src < prev

Wrap

Text File | 1988-05-03 | 79.4 KB | 1,809 lines

--:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --rosdep.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- -- -- package ROS_DEPENDENCIES -- -- -- ------------------------------------------------------------------------ ------------------------------------------------------------------------ with TEXT_IO; use TEXT_IO; package ROS_DEPENDENCIES is --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Package ROS_DEPENDENCIES is designed to support all of the -- -- packages that use file input/output with the ROS operating -- -- system. It includes all of the peculiarities and machine- -- -- dependencies that are not part of the Ada language. These -- -- include getting characters (GETC), indentation of lines in -- -- the ROS editor (INDENT_CHECK, PUT_NEW_LINE), and new OPEN, -- -- CREATE, and CLOSE(-UP) commands which automatically trans- -- -- late file names (from GET_FILENAME) to suit the ROS 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 packages written by this author. -- -- -- -- The compiler used in making this package was far from com- -- -- plete, so the solution is not necessarily the most elegant -- -- one the author could have used. Also, the compiler still -- -- followed the 1982 non-ANSI standard Ada. -- -- -- -- Author: Steven E. Nameroff, C1C, USAF -- -- Date : 15 July 1983 -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- procedure GETC (FILE : in FILE_TYPE; -- required due to the CHAR : out character; -- compiler POSITION : in out integer); procedure INDENT_CHECK (INF : in FILE_TYPE; -- required due to the CHAR1, -- editor CHAR2 : in out character; POSITION : in out integer); procedure PUT_END_LINE (OUTF : in FILE_TYPE); -- same as above procedure PUT_NEW_LINE (OUTF : in FILE_TYPE; -- same as above SPACES : integer); package ROS_FILE_OPS is -- all required due to -- the filer subtype NAME_TYPE is string (1..72); type LONG_FILE_NAME is record name : NAME_TYPE; LENGTH : natural; end record; procedure GET_FILENAME (LONG_NAME : out LONG_FILE_NAME); procedure open (FILE_NAME : in out FILE_TYPE; LONG_NAME : in LONG_FILE_NAME; SUFFIX : in string); procedure create (FILE_NAME : in out FILE_TYPE; LONG_NAME : in LONG_FILE_NAME; SUFFIX : in string); procedure CLOSE_UP (FILE_NAME : in out FILE_TYPE); -- All other file operations are the same as TEXT_IO -- versions, so are not needed here. end ROS_FILE_OPS; -- specifications. end ROS_DEPENDENCIES; -- specifications. ------------------- package body ROS_DEPENDENCIES ---------------------- ------------------------------------------------------------------------ with text_io; use text_io; package body ROS_DEPENDENCIES is ENDFILE : constant character := character'VAL (28); ---------------------------------------------------------------------- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- ---------------------------------------------------------------------- package body ROS_FILE_OPS is --------------------------------------------------------- -- This package contains all of the procedures that -- -- are necessary for using files with the ROS filer -- -- system. -- --------------------------------------------------------- DUMMY_CHAR : character; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure GET_FILENAME (LONG_NAME : out LONG_FILE_NAME) is ------------------------------------------ -- This procedure accepts input from -- -- the terminal for a correct system -- -- file name. -- ------------------------------------------ CHAR : character; INPUT_LINE : STRING(1..72); LENGTH_OF_INPUT : NATURAL; begin for CHAR in NAME_TYPE'RANGE loop -- zero out string LONG_NAME.name (CHAR) := ' '; end loop; LONG_NAME.LENGTH := 0; CHAR := 'a'; put ("enter name of file (suffix .TXT; assumed) : "); GET_LINE(INPUT_LINE, LENGTH_OF_INPUT); for I in 1..LENGTH_OF_INPUT loop CHAR := INPUT_LINE(I); -- File names can only have a certain set of characters in them. -- This part only adds legal characters to the filename. if ((CHAR = ' ') and (LONG_NAME.LENGTH /= 0)) or (((CHAR = ':') or (CHAR in '0'..'9')) and (LONG_NAME.LENGTH > 1)) or ((CHAR = '_') and (LONG_NAME.LENGTH /= 0)) or (CHAR in 'a'..'z') or (CHAR in 'A'..'Z') then LONG_NAME.LENGTH := LONG_NAME.LENGTH + 1; LONG_NAME.name (LONG_NAME.LENGTH) := CHAR; elsif CHAR = character'VAL (8) then -- account for backspaces LONG_NAME.LENGTH := LONG_NAME.LENGTH - 1; end if; end loop; new_line; end GET_FILENAME; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure ADD_SUFFIX (LONG_NAME : in out LONG_FILE_NAME; SUFFIX : in string) is ------------------------------------------ -- This procedure adds the necessary -- -- suffix to the name that the user -- -- gave in GET_FILENAME to make it a -- -- legal system file name. -- ------------------------------------------ begin for COUNT in positive loop LONG_NAME.name (LONG_NAME.LENGTH + 1) := SUFFIX (COUNT); LONG_NAME.LENGTH := LONG_NAME.LENGTH + 1; end loop; exception when CONSTRAINT_ERROR => -- uses this to exit the "for COUNT" loop, since it is not -- possible to determine beforehand the range on the suffix. LONG_NAME.LENGTH := LONG_NAME.LENGTH + 4; LONG_NAME.NAME (LONG_NAME.LENGTH - 3..LONG_NAME.LENGTH) := ".TXT"; end ADD_SUFFIX; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure open (FILE_NAME : in out FILE_TYPE; LONG_NAME : in LONG_FILE_NAME; SUFFIX : in string) is ------------------------------------------ -- This procedure opens a file with -- -- the name LONG_NAME, and the suffix -- -- SUFFIX. -- ------------------------------------------ DUMMY_NAME : LONG_FILE_NAME; begin DUMMY_NAME := LONG_NAME; ADD_SUFFIX (DUMMY_NAME, SUFFIX); -- All of the garbage below was necessary -- because the compiler didn't allow the -- programmer to open a file using a string OPEN_FILE_BLOCK : -- of length unknown at compilation time, -- unless it was in a block. declare subtype SHORT_FILE_NAME is string (1..DUMMY_NAME.LENGTH); SHORT_NAME : SHORT_FILE_NAME; begin SHORT_NAME := DUMMY_NAME.name (1..DUMMY_NAME.LENGTH); TEXT_IO.open (FILE_NAME, IN_FILE, SHORT_NAME); end OPEN_FILE_BLOCK; end open; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure create (FILE_NAME : in out FILE_TYPE; LONG_NAME : in LONG_FILE_NAME; SUFFIX : in string) is ------------------------------------------ -- This procedure creates a file with -- -- the name LONG_NAME and the suffix -- -- SUFFIX. -- ------------------------------------------ DUMMY_NAME : LONG_FILE_NAME; begin DUMMY_NAME := LONG_NAME; ADD_SUFFIX (DUMMY_NAME, SUFFIX); CREATE_FILE_BLOCK : -- see OPEN for explanation. declare subtype SHORT_FILE_NAME is string (1..DUMMY_NAME.LENGTH); SHORT_NAME : SHORT_FILE_NAME; begin SHORT_NAME := DUMMY_NAME.name (1..DUMMY_NAME.LENGTH); TEXT_IO.create (FILE_NAME, OUT_FILE, SHORT_NAME); end CREATE_FILE_BLOCK; end create; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure CLOSE_UP (FILE_NAME : in out FILE_TYPE) is ----------------------------------------------- -- This procedure closes FILE_NAME. -- ----------------------------------------------- begin close (FILE_NAME); -- before closing it. end CLOSE_UP; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - begin -- ROS_FILE_OPS initializations SET_INPUT(STANDARD_INPUT); end ROS_FILE_OPS; -- body. ---------------------------------------------------------------------- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- ---------------------------------------------------------------------- ---------------------------------------------------------------------- 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 -- The real reason why this procedure is in this particular package -- is that there was evidently a quirk in the compiler used -- the -- GET command would not get control characters. When this quirk is -- remedied, this procedure should be removed, a "get" substituted for -- the "read", and the whole sequence of statements should be moved -- to replace the procedure call, wherever it is found. -- I AM JUST FAKING IT FOR VAX, GET BUT NO CONTROLS WAW 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); while CHAR = character'VAL (0) loop -- eliminate all the nulls if END_OF_FILE(FILE) then raise END_ERROR; end if; if END_OF_LINE(FILE) then CHAR := CHARACTER'VAL(13); SKIP_LINE(FILE); exit; end if; get (FILE, CHAR); end loop; end if; POSITION := POSITION + 1; exception when END_ERROR => -- Expected at end of file raise; when others => put("unexpected exception in ROS_DEPENDENCIES.GETC"); new_line; raise; end GETC; ---------------------------------------------------------------------- procedure INDENT_CHECK (INF : in FILE_TYPE; CHAR1, CHAR2 : in out character; POSITION : in out integer) is --------------------------------------------------------- -- This procedure accounts for the unusual way that -- -- the system editor indicates automatic indentation. -- -- If it just uses blanks, this procedure may be null.-- --------------------------------------------------------- begin null; end INDENT_CHECK; ---------------------------------------------------------------------- procedure PUT_END_LINE (OUTF : in FILE_TYPE) is --------------------------------------------------------- -- This procedure outputs an end of line indicator to -- -- the file OUTF. -- --------------------------------------------------------- begin NEW_LINE(OUTF); end PUT_END_LINE; ---------------------------------------------------------------------- procedure PUT_NEW_LINE (OUTF : in FILE_TYPE; SPACES : integer) is --------------------------------------------------------- -- This procedure starts a new line in the file OUTF, -- -- using the system indentation indicators. -- --------------------------------------------------------- begin for I in 1..SPACES loop PUT(OUTF, ' '); end loop; end PUT_NEW_LINE; end ROS_DEPENDENCIES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --getoken.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- -- -- 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 ROS_DEPENDENCIES -- -- package, with the exception of any peculiarities that might -- -- occur due to using 1982 non-ANSI standard Ada. -- -- -- -- 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 (NUMBER, 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; ECHO_FILE : FILE_TYPE; TOKEN : in out STRING_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 ROS_DEPENDENCIES; use ROS_DEPENDENCIES; package body GETTOKEN is use ROS_FILE_OPS; use integer_io; subtype ARRAY_RANGE is integer range 0..STRING_LENGTH; type CHECK_ARRAY is array (ARRAY_RANGE) of character; type CHECK_RECORD is record CH : CHECK_ARRAY; NUM : ARRAY_RANGE; end record; TOKEN_STORAGE, DELIMITERS, LETTERS, NUMBERS : CHECK_RECORD; GARBAGE_FILE : FILE_TYPE; ---------------------------------------------------------------------- procedure LOAD_RECORD (DELS, LETS, NUMS : out CHECK_RECORD) is --------------------------------------------------------- -- This procedure loads the arrays of delimiters, let- -- -- ters, and numbers so that they can be separated. -- --------------------------------------------------------- begin for I in 1..10 loop NUMS.CH (I) := character'VAL (I + 47); end loop; NUMS.CH (11) := '_'; NUMS.CH (12) := '.'; NUMS.NUM := 12; for I in 1..26 loop LETS.CH (I) := character'VAL (I + 64); LETS.CH (I + 26) := character'VAL (I + 96); end loop; LETS.CH (53) := '_'; LETS.NUM := 53; DELS.CH (1) := '"'; DELS.CH (2) := ','; DELS.CH (3) := '&'; DELS.CH (4) := '''; DELS.CH (5) := '('; DELS.CH (6) := ')'; DELS.CH (7) := '*'; DELS.CH (8) := '+'; DELS.CH (09) := '-'; DELS.CH (10) := '/'; DELS.CH (11) := ':'; DELS.CH (12) := ';'; DELS.CH (13) := '<'; DELS.CH (14) := '>'; DELS.CH (15) := '='; -- Spaces and end-of-line indicators DELS.CH (16) := '|'; -- are not included in the delimiters DELS.CH (17) := '.'; -- since the language does not require DELS.CH (18) := BLANK_LINE; -- them. The BLANK_LINE is left as a -- delimiter because it would be lost DELS.NUM := 18; -- if it wasn't. end LOAD_RECORD; ---------------------------------------------------------------------- function IS_IN (CH : character; ARRY : CHECK_RECORD) return boolean is --------------------------------------------------------- -- This function determines whether a character, CH, -- -- is in a certain group (ARRY) or not. -- --------------------------------------------------------- IN_ARRY : boolean; begin IN_ARRY := false; for I in 1..ARRY.NUM loop -- your basic search with exit if CH = ARRY.CH (I) then IN_ARRY := true; exit; end if; end loop; return IN_ARRY; end IS_IN; ---------------------------------------------------------------------- procedure GET_TOKEN (INPUT_FILE : FILE_TYPE; ECHO_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 CURRENT_POSITION : LENGTH_TYPE := 1; -- the location of the current -- character on the line, of the -- input file CHAR : character; DOUBLE_PERIOD : constant character := character'VAL (1); -- see below -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure GET_CHAR (CH : out character; INF : FILE_TYPE) is ------------------------------------------ -- This procedure gets one character -- -- from the input file (INF). -- ------------------------------------------ DUMMY_CH : character := character'VAL(0); begin ROS_DEPENDENCIES.GETC (INF, CH, CURRENT_POSITION); TOKEN_STORAGE.NUM := TOKEN_STORAGE.NUM + 1; TOKEN_STORAGE.CH (TOKEN_STORAGE.NUM) := CH; 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; -- This seems to be set up for the ROS system and ought to be scrubbed ROS_DEPENDENCIES.INDENT_CHECK (INF, DUMMY_CH, CH, CURRENT_POSITION); if DUMMY_CH /= character'VAL (0) then TOKEN_STORAGE.NUM := TOKEN_STORAGE.NUM + 2; TOKEN_STORAGE.CH (TOKEN_STORAGE.NUM - 1) := DUMMY_CH; if CH = BLANK_LINE then TOKEN_STORAGE.CH (TOKEN_STORAGE.NUM) := END_OF_LINE; else TOKEN_STORAGE.CH (TOKEN_STORAGE.NUM) := CH; end if; end if; exception when END_ERROR => CH := character'VAL (3); CLOSE_UP (GARBAGE_FILE); when others => put("unexpected exception in GETTOKEN.GET_TOKEN.GET_CHAR"); new_line; 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 for I in 1..TOKEN_STORAGE.NUM - 1 loop if TOKEN_STORAGE.CH(I) = END_OF_LINE or TOKEN_STORAGE.CH(I) = BLANK_LINE then new_line(ECHO_FILE); else put (ECHO_FILE, TOKEN_STORAGE.CH (I)); end if; end loop; TOKEN_STORAGE.CH (1) := TOKEN_STORAGE.CH (TOKEN_STORAGE.NUM); TOKEN_STORAGE.NUM := 1; 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 IS_IN (CHAR, DELIMITERS) 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 IS_IN (CHAR, LETTERS) then TOKEN.POSITION := CURRENT_POSITION - 1; TOKEN.CLASS := WORD; PRESENT_STATE := WORD_STATE; ADD_ON (CHAR, TOKEN, INPUT_FILE); elsif IS_IN (CHAR, NUMBERS) then TOKEN.POSITION := CURRENT_POSITION - 1; TOKEN.CLASS := NUMBER; 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 IS_IN (CHAR, LETTERS) or else (IS_IN (CHAR, NUMBERS) 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 IS_IN (CHAR, NUMBERS) 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 exception when others => put("unexpected exception in GETTOKEN.GET_TOKEN"); NEW_LINE; RAISE; end GET_TOKEN; ---------------------------------------------------------------------- procedure GET_TOKEN (INPUT_FILE : FILE_TYPE; TOKEN : in out STRING_RECORD) is --------------------------------------------------------- -- This procedure is used when no echo-file is re- -- -- quired. In this case, it makes up an echo-file, -- -- and call the other procedure GET_TOKEN. -- --------------------------------------------------------- begin GET_TOKEN (INPUT_FILE, GARBAGE_FILE, TOKEN); end GET_TOKEN; ---------------------------------------------------------------------- begin -- initializations LOAD_RECORD (DELIMITERS, LETTERS, NUMBERS); TEXT_IO.create (GARBAGE_FILE, OUT_FILE, "GARBAGE.TXT"); -- see above TOKEN_STORAGE.NUM := 0; end GETTOKEN; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --stubsup.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- 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 ROS_DEPENDENCIES package. One -- -- must also note that this set of packages was written using -- -- a non ANSI-standard 1982 Ada compiler. Also, the compiler -- -- used did not implement many of the "nifty" things that Ada -- -- supports, so this solution is not the most elegent one. -- -- -- -- Author: Steven E. Nameroff, C1C, USAF -- -- Date : 15 July 1983 -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- type KEY_WORDS is (KW_PACKAGE, KW_FUNCTION, KW_PROCEDURE, KW_BODY, KW_ACCEPT, KW_BEGIN, KW_CASE, KW_IF, KW_LOOP, KW_END, KW_TYPE, KW_FOR, KW_USE, KW_NEW, KW_SEPARATE, KW_IS, KW_RECORD, 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_PROCEDURE; 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 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 (INF : FILE_TYPE; OUTF : FILE_TYPE; TOKEN : in out STRING_RECORD); 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 ROS_DEPENDENCIES; use ROS_DEPENDENCIES; package body STUBBER_SUPPORT is use ROS_FILE_OPS; type KEYW_TYPE is array (KW_PACKAGE..NOT_KW) of string (1..10); KW : KEYW_TYPE; FIRST_TIME_THROUGH_STUB : BOOLEAN; ---------------------------------------------------------------------- procedure GET_ONE_TOKEN (INF : FILE_TYPE; OUTF : FILE_TYPE; TOKEN : in out STRING_RECORD) 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 (INF, OUTF, 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 GET_TOKEN (INF, OUTF, TOKEN); end loop; end GET_ONE_TOKEN; ---------------------------------------------------------------------- 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). -- --------------------------------------------------------- FILENAME : ROS_FILE_OPS.LONG_FILE_NAME; 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 (" STUBBER"); new_line; new_line; put ("This program stubs anything in your program that needs to be"); new_line; put ("stubbed. You need do nothing to tell the stubber what needs"); new_line; put ("to be stubbed; it figures it out by itself. It is imperative"); new_line; put ("that the program being stubbed is syntactically correct, at"); new_line; put ("least to the point that each 'if' has and 'end if', etc. If"); new_line; put ("this is not the case, then the stubber will self-destruct or"); new_line; put ("worse than that, it will miss-stub your program. This stub-"); new_line; put ("ber will also keep you informed as to where it is and what's"); new_line; put ("being stubbed."); new_line; new_line; new_line; new_line; new_line; new_line; GET_FILENAME (FILENAME); ROS_FILE_OPS.open (INPUT_FILE, FILENAME, ""); OUTFILE_ID.LENGTH := FILENAME.LENGTH; OUTFILE_ID.STR (1..OUTFILE_ID.LENGTH) := FILENAME.NAME (1..OUTFILE_ID.LENGTH); ROS_FILE_OPS.create (OUTPUT_FILE, FILENAME, "2"); -- #### PUT_NEW_LINE (OUTPUT_FILE, 0); TOKEN.LENGTH := STRING_LENGTH - 1; -- this will force a blank-out TOKEN.STR_ZERO:= GETTOKEN.END_OF_LINE; exception when others => put("Unhandled exception in STUBBER_SUPPORT.INITIALIZE"); new_line; 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 (FILE_ID.STR (1..FILE_ID.LENGTH)); put ("2.TXT;"); new_line; put ("Be sure to edit and save the file before printing it. "); new_line; put ("It is also recommended that you use the FORMAT set of "); new_line; put ("packages to format the stubbed version, once it is "); new_line; put ("synactically perfect."); new_line; CLOSE_UP (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; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 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; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - begin -- STUB CURRENT_DEC := SPECIFICATION; new_line (OUTPUT_FILE); new_line (OUTPUT_FILE); if FIRST_TIME_THROUGH_STUB then FIRST_TIME_THROUGH_STUB := FALSE; put ( OUTPUT_FILE, "with TEXT_IO; use TEXT_IO;"); new_line (OUTPUT_FILE); 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)); case CURRENT_DEC.TYPE_OF_DEC is when KW_PROCEDURE => put (OUTPUT_FILE, " procedure "); when KW_FUNCTION => put (OUTPUT_FILE, " function "); when KW_PACKAGE => put (OUTPUT_FILE, "package body "); end case; 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 new_line (OUTPUT_FILE); STUB (CURRENT_DEC.INTERNAL_DECS); -- recursive call to handle the -- internal specifications new_line (OUTPUT_FILE); put (OUTPUT_FILE, "end "); put (OUTPUT_FILE, CURRENT_DEC.DEC_NAME.STR (1..CURRENT_DEC.DEC_NAME.LENGTH)); put (OUTPUT_FILE, "; -- body"); new_line (OUTPUT_FILE); else CURRENT_BUFF := CURRENT_DEC.FORMAL_PART; while CURRENT_BUFF /= null loop put (OUTPUT_FILE, CURRENT_BUFF.BUFFER_STRING.STR (1..CURRENT_BUFF.BUFFER_STRING.LENGTH)); CURRENT_BUFF := CURRENT_BUFF.NEXT_ONE; if CURRENT_BUFF /= null then new_line (OUTPUT_FILE); end if; end loop; if CURRENT_DEC.TYPE_OF_DEC = KW_FUNCTION then put (OUTPUT_FILE, " return "); put (OUTPUT_FILE, CURRENT_DEC.RETURN_TYPE.STR (1..CURRENT_DEC.RETURN_TYPE.LENGTH)); end if; put (OUTPUT_FILE, " is"); new_line (OUTPUT_FILE); new_line (OUTPUT_FILE); if CURRENT_DEC.TYPE_OF_DEC = KW_FUNCTION then -- all functions put (OUTPUT_FILE, " DUMMY : "); -- require a return 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" then put (OUTPUT_FILE, " := 1"); elsif CURRENT_DEC.RETURN_TYPE.STR (1..CURRENT_DEC.RETURN_TYPE.LENGTH) = "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, " := ""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); end if; -- accounted for, a -- 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. put (OUTPUT_FILE, " begin"); new_line (OUTPUT_FILE); put (OUTPUT_FILE, " put (""I AM NOW IN "); WRITE_ID (OUTPUT_FILE, CURRENT_DEC.DEC_NAME); put (OUTPUT_FILE, """);"); new_line (OUTPUT_FILE); put (OUTPUT_FILE, " new_line;"); new_line (OUTPUT_FILE); if CURRENT_DEC.TYPE_OF_DEC = KW_FUNCTION then put (OUTPUT_FILE, " return DUMMY;"); new_line (OUTPUT_FILE); end if; new_line (OUTPUT_FILE); put (OUTPUT_FILE, " exception"); new_line (OUTPUT_FILE); put (OUTPUT_FILE, " when others =>"); new_line (OUTPUT_FILE); put (OUTPUT_FILE, " put(""Unhandled exception in "); put (OUTPUT_FILE, CURRENT_DEC.DEC_NAME.STR (1..CURRENT_DEC.DEC_NAME.LENGTH)); put (OUTPUT_FILE, """);"); new_line (OUTPUT_FILE); put (OUTPUT_FILE, " raise;"); new_line (OUTPUT_FILE); put (OUTPUT_FILE, " end "); put (OUTPUT_FILE, CURRENT_DEC.DEC_NAME.STR (1..CURRENT_DEC.DEC_NAME.LENGTH)); put (OUTPUT_FILE, ';'); new_line (OUTPUT_FILE); end if; CURRENT_DEC := CURRENT_DEC.NEXT_DEC; new_line (OUTPUT_FILE); new_line (OUTPUT_FILE); end loop; exception when others => put("Unhandled exception in STUBBER_SUPPORT.STUB"); new_line; 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 (INPUT_FILE, OUTPUT_FILE, 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 (INPUT_FILE, OUTPUT_FILE, TOKEN); end loop; GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); -- This last GET_ONE is -- to eliminate the -- possibility of the -- procedure finding the -- "if" of an "end if", etc. end GET_PAST_END; ---------------------------------------------------------------------- procedure LOAD_KEY_WORDS is --------------------------------------------------------- -- This procedure loads the key words (the words that -- -- the stubber cares about) into the key words array, -- -- to be used by the function CONVERT. -- --------------------------------------------------------- begin KW (KW_PACKAGE) := "PACKAGE "; KW (KW_FUNCTION) := "FUNCTION "; KW (KW_PROCEDURE) := "PROCEDURE "; KW (KW_BODY) := "BODY "; KW (KW_ACCEPT) := "ACCEPT "; KW (KW_BEGIN) := "BEGIN "; KW (KW_CASE) := "CASE "; KW (KW_IF) := "IF "; KW (KW_LOOP) := "LOOP "; KW (KW_END) := "END "; KW (KW_TYPE) := "TYPE "; KW (KW_FOR) := "FOR "; KW (KW_USE) := "USE "; KW (KW_RECORD) := "RECORD "; KW (KW_NEW) := "NEW "; KW (KW_SEPARATE) := "SEPARATE "; KW (KW_IS) := "IS "; KW (NOT_KW) := "NOT A KW "; end LOAD_KEY_WORDS; ---------------------------------------------------------------------- function CONVERT (STR1 : STRING_RECORD) return KEY_WORDS is --------------------------------------------------------- -- This function determines if an identifier is a key -- -- word. If not, the function returns the value -- -- NOT_KW. -- --------------------------------------------------------- CONV : KEY_WORDS := KW_PACKAGE; begin while CONV < NOT_KW loop if KW (CONV) = STR1.STR (1..10) then -- your basic sentinel search exit; end if; CONV := KEY_WORDS'SUCC (CONV); end loop; return CONV; end CONVERT; ---------------------------------------------------------------------- begin -- initializations LOAD_KEY_WORDS; FIRST_TIME_THROUGH_STUB := TRUE; end STUBBER_SUPPORT; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --stubber.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- -- -- procedure STUBBER -- -- -- ------------------------------------------------------------------------ ------------------------------------------------------------------------ with GETTOKEN; use GETTOKEN; with STUBBER_SUPPORT; use STUBBER_SUPPORT; with TEXT_IO; use TEXT_IO; 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 -- -- ROS_DEPENDENCIES (that STUBBER_SUPPORT uses). The compiler -- -- used to write these programs was a 1982 (non ANSI standard) -- -- Ada compiler, so these packages will need to be updated be- -- -- fore they will run on a Mil Std 1815A Ada compiler. Please -- -- also note that the compiler used (Telesoft) couldn't handle -- -- many of the Ada constructs, so the solution here is not the -- -- most elegant one that the user could think of. (NOTE: the -- -- STUBBER does handle all cases, even though the compiler did -- -- not.) -- -- -- -- PACKAGE SET DEPENDENCE: -- -- -- -- >STUBBER -- -- | | -- -- | \___>STUBBER_SUPPORT -- -- | | | -- -- | | \_______________________>ROS_DEPENDENCIES -- -- | | / -- -- | \_________>GETTOKEN | -- -- \______________/ \_______/ -- -- -- -- -- -- Author: Steven E. Nameroff, C1C, USAF -- -- Date : 15 July 1983 -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- --------------------------------------------------------- -- 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("Unhandled exception in STUBBER.FORMAL_PARTS_MATCH"); new_line; 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 := 11; -- used to indent multiple -- declarations inside the -- formal part begin 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 (INPUT_FILE, OUTPUT_FILE, 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); TEMP_DEC.BUFFER_STRING.LENGTH := TEMP_DEC.BUFFER_STRING.LENGTH + TOKEN.LENGTH + 1; TEMP_DEC.BUFFER_STRING.STR (TEMP_DEC.BUFFER_STRING.LENGTH) := ' '; GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); if TOKEN.STR (1) = '(' then PARENTHESIS_COUNT := PARENTHESIS_COUNT + 1; elsif TOKEN.STR (1) = ')' then PARENTHESIS_COUNT := PARENTHESIS_COUNT - 1; 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 (INPUT_FILE, OUTPUT_FILE, 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.STR (TEMP_DEC.BUFFER_STRING.LENGTH) := ')'; GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); end if; exception when others => PUT("Unhandled exception in STUBBER.DO_FORMAL_PART"); new_line; 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; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 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("Unhandled exception in STUBBER.DO_SPEC.CLOSE_OFF"); new_line; 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. -- ------------------------------------------ begin CURRENT_SPEC.TYPE_OF_DEC := KW_PACKAGE; GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); if CONVERT (TOKEN) = KW_BODY then GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); -- id CURRENT_SPEC.DEC_NAME := TOKEN; GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, 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 (EXAXT 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 (INPUT_FILE, OUTPUT_FILE, TOKEN); -- 'IS' | 'RENAMES' if CONVERT (TOKEN) = KW_IS then GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); if CONVERT (TOKEN) /= KW_NEW then -- found package spec. 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); CURRENT_SPEC.NEXT_DEC := new DECLARATION_BUFF; CURRENT_SPEC := CURRENT_SPEC.NEXT_DEC; end if; end if; end if; exception when others => PUT("Unhandled exception in STUBBER.DO_SPEC.FOUND_WORD_PACKAGE"); new_line; raise; end FOUND_WORD_PACKAGE; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - procedure FOUND_SUBPROGRAM is ------------------------------------------ -- This procedure, called when the re- -- -- served word "procedure" or the re- -- -- served word "function" is found, -- -- determines if the structure is a -- -- subprogram specification or body, -- -- and takes appropriate action. -- ------------------------------------------ begin -- store everything, whether it'll be used or not CURRENT_SPEC.TYPE_OF_DEC := CONVERT (TOKEN); GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); -- id CURRENT_SPEC.DEC_NAME := TOKEN; GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); DO_FORMAL_PART (CURRENT_SPEC); if CURRENT_SPEC.TYPE_OF_DEC = KW_FUNCTION then GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); -- id CURRENT_SPEC.RETURN_TYPE := TOKEN; GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); end if; if TOKEN.STR (1) = ';' then -- found subprogram spec. 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 (INPUT_FILE, OUTPUT_FILE, 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("Unhandled exception in STUBBER.DO_SPEC.FOUND_SUBPROGRAM"); new_line; raise; end FOUND_SUBPROGRAM; -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 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 => FOUND_SUBPROGRAM; 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 while CONVERT (TOKEN) /= KW_IS and TOKEN.STR (1) /= ';' loop GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); if TOKEN.STR (1) = '(' then while TOKEN.STR (1) /= ')' loop GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); end loop; end if; end loop; if CONVERT (TOKEN) = KW_IS then GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, 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" while CONVERT (TOKEN) /= KW_USE loop GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); end loop; GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); if CONVERT (TOKEN) = KW_RECORD then GET_PAST_END; end if; when others => null; end case; GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, TOKEN); -- anything end loop; CURRENT_SPEC := null; exception when others => PUT("Unhandled exception in STUBBER.DO_SPEC"); new_line; raise; end DO_SPEC; ---------------------------------------------------------------------- begin -- stubber INITIALIZE (NEWFILE_ID); GET_ONE_TOKEN (INPUT_FILE, OUTPUT_FILE, 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. 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_PACKAGE. This pro- -- cedure 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. 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("Unhandled exception in STUBBER"); new_line; raise; end STUBBER;