Programmer's ROM - The Computer Language Library

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

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

Wrap

Text File | 1988-05-03 | 400.1 KB | 10,162 lines

:::::::::: stylesrc.dis :::::::::: @STYLE_CMP.DIS STYLE_CMP.CLI -- The following is the command file to invoke the style checker STYLE.CLI style_help.ini :::::::::: STYLE_CMP.DIS :::::::::: -- -- Compilation order for STYLE_CHECKER -- -- -- DYN (dynamic string) package (specification and body) dyn.ada -- FILE_HANDLING package specification -- file_spec.ada filespec.ada -- TOKENIZER package specification -- tokenizer_spec.ada tokenzspe.ada -- STYLE_PARAMETERS package specification -- style_param_spec.ada sparamspe.ada -- REPORT_GENERATOR package specification -- report_gen_spec.ada repgenspe.ada -- STACK_PACKAGE package (specification and body) -- stack_package.ada stackpack.ada -- two packages from spelling checker -- TOKEN_DEFINITION package (specification and body) -- token_definition.ada tokendefi.ada -- MANAGER package (specification and body) manager.ada -- HELP package specification -- help_file_spec.ada helpfiles.ada -- COMMAND_LINE_HANDLER package (specification and body) -- command_line.ada commandli.ada -- HELP_UTILITY packages -- HELP_SPEC.ADA helpspec.ada -- HELPINFO_SPEC.ADA HELPINFOS.ADA -- HELPINFO_BODY.ADA HELPINFOB.ADA -- HELP_BODY.ADA HELPBODY.ADA -- HELP_DIS_ALL.ADA HELPDISAL.ADA -- HELP_EXIT.ADA HELPEXIT.ADA -- HELP_FIND.ADA HELPFIND.ADA -- HELP_GET.ADA HELPGET.ADA -- HELP_INIT.ADA HELPINIT.ADA -- HELP_ME.ADA HELPME.ADA -- HELP_MENU.ADA HELPMENU.ADA -- HELP_PROMPT.ADA HELPPROMP.ADA -- HELP_RESET.ADA HELPRESET.ADA -- HELP_TEXT.ADA HELPTEXT.ADA -- -- -- And now the bodies... -- -- HELP package body -- help_file_body.ada HELPFILEB.ADA -- FILE_HANDLING package body -- file_body.ada filebody.ada -- TOKENIZER package body and all its seperate files -- tokenizer_body.ada tokenzbod.ada insert.ada -- is_a_reserved_word.ada isareserv.ada -- reserved_word.ada reservedw.ada -- next_character.ada nextchara.ada -- next_identifier.ada nextident.ada -- build_tokens.ada buildtoke.ada -- line_containing.ada lineconta.ada -- tree_root.ada treeroot.ada -- STYLE_PARAMETERS package body -- style_param_body.ada SPARAMBOD.ADA -- REPORT_GENERATOR package body -- report_gen_body.ada repgenbod.ada -- Main procedure (STYLE_CHECKER) and all its seperate files -- style_checker.ada stylechec.ada -- begin_of_line_indent.ada beginofli.ada -- check_statements.ada checkstat.ada -- check_end_of_blocks.ada checkendo.ada -- check_the_style.ada checkthes.ada -- check_for_attribute.ada checkfora.ada -- check_object_names.ada checkobje.ada -- check_universal.ada checkuniv.ada -- comment_token.ada commentto.ada -- current_token.ada currentto.ada -- entering_block.ada enteringb.ada -- entering_sub_block.ada enterings.ada -- exiting_block.ada exitingbl.ada -- get_next_token.ada getnextto.ada -- is_statement.ada isstateme.ada literal.ada -- new_line_token.ada newlineto.ada -- non_trivial_token.ada nontrivia.ada -- object_name.ada objectnam.ada -- reserve_word.ada reservewo.ada -- search_backward.ada srchbackw.ada -- search_back_one_of.ada srchbacko.ada -- search_forward.ada srchforwa.ada -- search_fore_one_of.ada srchforeo.ada -- type_declaration.ada typedecla.ada :::::::::: dyn.ada :::::::::: with text_io; use text_io; package DYN is ------------------------------------------------------------------------------ -- This is a package of several string manipulation functions based on -- -- a built-in dynamic string type DYN_STRING. It is an adaptation and -- -- extension of the package proposed by Sylvan Rubin of Ford Aerospace and -- -- Communications Corporation in the Nov/Dec 1984 issue of the Journal of -- -- Pascal, Ada and Modula-2. Some new functions have been added, the -- -- SUBSTRING function has been modified to permit it to return the right -- -- part of a string if the third parameter is permitted to default, and -- -- much of the body code has been rewritten. -- ------------------------------------------------------------------------------ -- R.G. Cleaveland 07 December 1984: -- -- Implementation initially with the Telesoft Ada version -- -- This required definition of the DYN_STRING type without use of a -- -- discriminant; an arbitrary maximum string length was chosen. This -- -- should be changed when an improved compiler is available. -- ------------------------------------------------------------------------------ -- Richard Powers 03 January 1985: -- -- changed to be used with a real compiler. -- -- Some of the routines removed by my whim. -- ------------------------------------------------------------------------------ -- Richard Powers 26 January 1985: -- Added UPPER_CASE function ------------------------------------------------------------------------------ type DYN_STRING is private; STRING_TOO_SHORT: exception; function D_STRING(CHAR: character) return DYN_STRING; -- Creates a one-byte dynamic string of contents CHAR. function D_STRING(STR : string ) return DYN_STRING; -- Creates a dynamic string of contents STR. -- The following four functions convert from dynamic strings to the -- desired representation: function CHAR(DSTR: DYN_STRING) return character; function STR (DSTR: DYN_STRING) return string; function INT (DSTR: DYN_STRING) return integer; function FLT (DSTR: DYN_STRING) return float; function LENGTH(DSTR: DYN_STRING) return natural; function "<" (DS1, DS2: DYN_STRING) return boolean; function "&" (DS1, DS2: DYN_STRING) return DYN_STRING; function SUBSTRING (DSTR: DYN_STRING; -- Returns a subpart of this string START : natural; -- starting at this position LENGTH : natural := 0) -- and of this length. return DYN_STRING; -- if LENGTH is zero or not specified, the remainder of the -- string is returned (eg the "RIGHT" function). function INDEX (SOURCE_STRING, --If this string contains PATTERN_STRING: DYN_STRING; --this string starting at or AFTER START_POS: integer) --this position, the position of return integer; --such start is returned. -- If the string lengths prohibit the search -1 is returned. -- If no match was found, 0 is returned. -- (This is like the INSTR function of BASIC). function RINDEX (SOURCE_STRING, --If this string contains PATTERN_STRING: DYN_STRING; --this string starting at or BEFORE START_POS: integer) --this position, the position of return integer; --such start is returned. -- If the string lengths prohibit the search -1 is returned. -- If no match was found, 0 is returned. function UPPER_CASE(STRG : in DYN.DYN_STRING) return STRING; -- Return the input string in upper case private type STRING_CONTENTS(SIZE : natural := 0) is record DATA: string(1..SIZE); end record; type DYN_STRING is access STRING_CONTENTS; end DYN; ---------------------------------------------------------------------------- package body DYN is package MY_INTEGER_IO is new INTEGER_IO(INTEGER); package MY_FLOAT_IO is new FLOAT_IO(FLOAT); function "&" (DS1, DS2: DYN_STRING) return DYN_STRING is DS3 : DYN_STRING; begin DS3 := new STRING_CONTENTS(DS1.SIZE+DS2.SIZE); DS3.DATA(1..DS3.SIZE):= DS1.DATA(1..DS1.SIZE) & DS2.DATA(1..DS2.SIZE); return DS3; end "&"; function D_STRING(CHAR: character) return DYN_STRING is DS : DYN_STRING; begin DS := new STRING_CONTENTS(SIZE=>1); DS.DATA(1) := CHAR; return DS; end D_STRING; function D_STRING(STR : string ) return DYN_STRING is DS : DYN_STRING; begin DS := new STRING_CONTENTS(SIZE => STR'length); DS.DATA(1..DS.SIZE) := STR; return DS; end D_STRING; function CHAR(DSTR: DYN_STRING) return character is begin return DSTR.DATA(1); end CHAR; function STR (DSTR: DYN_STRING) return string is begin return DSTR.DATA(1..DSTR.SIZE); end STR; function INT (DSTR: DYN_STRING) return integer is V: integer; L: positive; begin MY_INTEGER_IO.get(STR(DSTR),V,L); return V; end INT; function FLT (DSTR: DYN_STRING) return float is V: float; L: positive; begin MY_FLOAT_IO.get(STR(DSTR),V,L); return V; end FLT; function LENGTH(DSTR: DYN_STRING) return natural is begin return DSTR.SIZE; end LENGTH; function "<" (DS1, DS2: DYN_STRING) return boolean is begin if STR(DS1) < STR(DS2) then return (TRUE); else return (FALSE); end if; end "<"; function SUBSTRING (DSTR: DYN_STRING; START : natural; LENGTH : natural := 0) return DYN_STRING is DS: DYN_STRING; L : natural := LENGTH; begin if (START < 1) or (START > DSTR.SIZE) then raise CONSTRAINT_ERROR; else if L = 0 then L := DSTR.SIZE-START+1; end if; if DSTR.SIZE < START + L - 1 then raise STRING_TOO_SHORT; else DS := new STRING_CONTENTS(L); DS.DATA(1..L) := DSTR.DATA(START..START+L-1); return DS; end if; end if; end SUBSTRING; function INDEX(SOURCE_STRING, PATTERN_STRING: DYN_STRING; START_POS: integer) return integer is NO_MATCH : integer := 0; NO_FIT : integer := -1; begin if SOURCE_STRING.SIZE < PATTERN_STRING.SIZE + START_POS - 1 or START_POS < 1 then return NO_FIT; end if; for I in START_POS..SOURCE_STRING.SIZE-PATTERN_STRING.SIZE+1 loop if SOURCE_STRING.DATA(I..I+PATTERN_STRING.SIZE-1) = PATTERN_STRING.DATA(1..PATTERN_STRING.SIZE) then return I; end if; end loop; return NO_MATCH; end INDEX; function RINDEX(SOURCE_STRING, PATTERN_STRING: DYN_STRING; START_POS: integer) return integer is NO_MATCH : integer := 0; NO_FIT : integer := -1; begin if SOURCE_STRING.SIZE < PATTERN_STRING.SIZE + START_POS - 1 or START_POS < 1 then return NO_FIT; end if; for I in reverse 1..START_POS loop if SOURCE_STRING.DATA(I..I+PATTERN_STRING.SIZE-1) = PATTERN_STRING.DATA(1..PATTERN_STRING.SIZE) then return I; end if; end loop; return NO_MATCH; end RINDEX; function UPPER_CASE(STRG : in DYN.DYN_STRING) return STRING is ANSWER : STRING(1..LENGTH(STRG)); begin ANSWER := STR(STRG); for I in 1..LENGTH(STRG) loop if (ANSWER(I) >= 'a') and (ANSWER(I) <= 'z') then ANSWER(I) := CHARACTER'VAL(CHARACTER'POS(ANSWER(I)) - CHARACTER'POS('a') + CHARACTER'POS('A')); end if; end loop; return ANSWER; end UPPER_CASE; end DYN; :::::::::: filespec.ada :::::::::: -- -- FILE_HANDLING by Richard Conn, TI Ada Technology Branch -- 28 Feb 85 -- with TEXT_IO; package FILE_HANDLING is -------------------------------------------------------------------------- -- Abstract : FILE_HANDLING returns FILE_IDs for all files specified -- as parameters, either directly or indirectly, in the -- command line. Any file name prefixed by the special -- character '@' is an indirect file, which contains the -- names of other files to check and other indirect files. -- Indirect files may be nested several levels deep (set by -- a constant), and the prefix character for indirect files -- may be changed (also by a constant). -------------------------------------------------------------------------- HELP_ASKED_FOR : exception; HELP_FILE_NAME : constant STRING := "STYLE_HELP.INI"; STYLE_DICTIONARY_NAME : constant STRING := "STYLE_DICTIONARY.INI"; procedure INPUT_FILE_ID (FILE_ID : in out TEXT_IO.FILE_TYPE; MORE_FILES : out BOOLEAN); -------------------------------------------------------------------------- -- Abstract : INPUT_FILE_ID returns the next file id of the next file -- in the direct or indirect file name list from the -- command line. -------------------------------------------------------------------------- -- Parameters : FILE_ID - ID of next file -- MORE_FILES - FALSE if no more files available -- (FILE_ID is also invalid at this point) -------------------------------------------------------------------------- procedure OUTPUT_FILE_ID (FLAWS_FILE_ID : in out TEXT_IO.FILE_TYPE; STYLE_FILE_ID : in out TEXT_IO.FILE_TYPE); -------------------------------------------------------------------------- -- Abstract : OUTPUT_FILE_ID returns the file IDs of the Flaws and Style -- files. The names of these files were built from the first -- file indicated in the list of file names. -------------------------------------------------------------------------- -- Parameters : FLAWS_FILE_ID - ID of Flaws File -- STYLE_FILE_ID - ID of Style File -------------------------------------------------------------------------- end FILE_HANDLING; :::::::::: tokenzspe.ada :::::::::: with DYN; with TEXT_IO; package TOKENIZER is -------------------------------------------------------------------------- -- Abstract : This package contains the interfaces to the Tokenizer part -- of the Style_Checker. The tokenizer splits the input Ada -- source into "tokens". -------------------------------------------------------------------------- type TOKEN is private; -- Ranges subtype LINE_NUM_RANGE is NATURAL range 0 .. NATURAL'LAST; subtype LINE_INDEX_RANGE is NATURAL range 0 .. 255; -- Types of tokens type TOKEN_TYPE is ( -- First the reserved word tokens, alphabetized by LENGTH AT_TOKEN, DO_TOKEN, IF_TOKEN, IN_TOKEN, IS_TOKEN, OF_TOKEN, OR_TOKEN, ABS_TOKEN, ALL_TOKEN, AND_TOKEN, END_TOKEN, FOR_TOKEN, MOD_TOKEN, NEW_TOKEN, NOT_TOKEN, OUT_TOKEN, REM_TOKEN, USE_TOKEN, XOR_TOKEN, BODY_TOKEN, CASE_TOKEN, ELSE_TOKEN, EXIT_TOKEN, GOTO_TOKEN, LOOP_TOKEN, NULL_TOKEN, TASK_TOKEN, THEN_TOKEN, TYPE_TOKEN, WHEN_TOKEN, WITH_TOKEN, ABORT_TOKEN, ARRAY_TOKEN, BEGIN_TOKEN, DELAY_TOKEN, DELTA_TOKEN, ELSIF_TOKEN, ENTRY_TOKEN, RAISE_TOKEN, RANGE_TOKEN, WHILE_TOKEN, ACCEPT_TOKEN, ACCESS_TOKEN, DIGITS_TOKEN, OTHERS_TOKEN, PRAGMA_TOKEN, RECORD_TOKEN, RETURN_TOKEN, SELECT_TOKEN, DECLARE_TOKEN, GENERIC_TOKEN, LIMITED_TOKEN, PACKAGE_TOKEN, PRIVATE_TOKEN, RENAMES_TOKEN, REVERSE_TOKEN, SUBTYPE_TOKEN, CONSTANT_TOKEN, FUNCTION_TOKEN, SEPARATE_TOKEN, EXCEPTION_TOKEN, PROCEDURE_TOKEN, TERMINATE_TOKEN, -- Followed by the other tokens (in no particular order) END_OF_LINE, END_OF_FILE, IDENTIFIER, NUMERIC_LITERAL, STRING_LITERAL, CHARACTER_LITERAL, CONCATENATION_OPERATOR, -- & TICK, -- ' RIGHT_PARENTHESIS, -- ( LEFT_PARENTHESIS, -- ) MULTIPLICATION_OPERATOR, -- * ADDITION_OPERATOR, -- + COMMA, -- , SUBTRACTION_OPERATOR, -- - PERIOD, -- . DIVISION_OPERATOR, -- / COLON, -- : SEMICOLON, -- ; LESS_THAN_OPERATOR, -- < EQUAL_OPERATOR, -- = GREATER_THAN_OPERATOR, -- > VERTICAL_BAR, -- | COMMENT, -- -- ARROW, -- => DOUBLE_DOT, -- .. EXPONENTIATE_OPERATOR, -- ** ASSIGNMENT_OPERATOR, -- := INEQUAL_OPERATOR, -- /= GREATER_THAN_OR_EQUAL_OPERATOR, -- >= LESS_THAN_OR_EQUAL_OPERATOR, -- <= LEFT_LABEL_BRACKET, -- << RIGHT_LABEL_BRACKET, -- >> BOX, -- <> ANYTHING_ELSE); subtype KEYWORDS is TOKEN_TYPE range AT_TOKEN .. TERMINATE_TOKEN; -- Types associated with the IDENTIFIER binary tree type REFS; -- occurrence of an identifier type REFPTR is access REFS; -- pointers to references type REFS is -- record STRG : DYN.DYN_STRING; -- identifier NEXT : REFPTR; -- chained to other occurrences end record; type IDENTIFIER_NODE; -- element of identifier tree type IDENTIFIER_TREE is access IDENTIFIER_NODE; -- binary tree used to sort type IDENTIFIER_NODE is -- Tokens record LEFT, RIGHT : IDENTIFIER_TREE; -- links to other nodes REFERENCES : REFPTR; -- identifier chain end record; -- Externally visible functions and procedures function EXTERNAL_REPRESENTATION(CURRENT_TOKEN : in TOKEN) return DYN.DYN_STRING; function TREE_ROOT return IDENTIFIER_TREE; function FIRST_TOKEN return TOKEN; function LENGTH_OF_COMMENT(CURRENT_TOKEN : in TOKEN) return NATURAL; function NEXT_TOKEN(CURRENT_TOKEN : in TOKEN) return TOKEN; function PREVIOUS_TOKEN(CURRENT_TOKEN : in TOKEN) return TOKEN; function TYPE_OF_TOKEN_IS(CURRENT_TOKEN : in TOKEN) return TOKEN_TYPE; procedure BUILD_TOKENS; procedure TOKEN_POSITION(CURRENT_TOKEN : in TOKEN; LINE : out LINE_NUM_RANGE; COLUMN : out LINE_INDEX_RANGE); procedure LINE_CONTAINING_TOKEN(CURRENT_TOKEN : in TOKEN; LINE : out DYN.DYN_STRING); -- Exceptions exported END_OF_TOKENS : exception; -- End of token signal INVALID_TOKEN : exception; -- Invalid token passed in private -- Types used for identifier tree type TOKEN_POINTER is access TOKEN; type TOKEN_POSITION_RECORD is record LINE : LINE_NUM_RANGE; COLUMN : LINE_INDEX_RANGE; end record; type TOKEN is record TYPE_OF_TOKEN : TOKEN_TYPE; PHYSICAL_REPRESENTATION : DYN.DYN_STRING; TOKEN_POSITION : TOKEN_POSITION_RECORD; NEXT_TOKEN : TOKEN_POINTER; PREVIOUS_TOKEN : TOKEN_POINTER; end record; end TOKENIZER; :::::::::: sparamspe.ada :::::::::: ------ CPCI-Level PROLOGUE ------ --|CPCI Name I: Style_Parameters --|Responsible Manager : John Mellby --|CPCI II: Style_Parameters --|Compliance I: -- --|Abstract I: This package is responsible for inputting the -- parameters determining the style from a file, -- then making them available to the 'style-checking' -- remainder of the system. -- --|Notes I: -- --|Implementation Language : Ada --|LOC II: --|Requirements I: --|Requirements, Derived: The parameters defining the "Style" will be -- read into the program from a file. --|Requirements, Implied: --|Technical References : -- --|Program References with DYN; -- Dynamic String Package with Tokenizer; ---- END CPCI-Level PROLOGUE ---- -- Style Checker -- P A R A M E T E R S -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - package Style_Parameters is Number_of_Keywords : constant integer := 1 + (Tokenizer.Keywords'pos(Tokenizer.Keywords'last)) - (Tokenizer.Keywords'pos(Tokenizer.Keywords'first)); subtype Keyword_Range is integer range 0..Number_of_Keywords; type Keyword_Options is (All_Keys, Used, Not_Used, Errors, None); type Require_Type is (Required, Not_Required); -- Word and case parameters subtype Word_Lengths is natural; type Reserve_Word_Cases is (Reserved_Case_Upper, Reserved_Case_Lower, Reserved_Case_Consistant, Reserved_Case_Any); type Object_Name_Cases is (Name_Case_Upper, Name_Case_Lower, Name_Case_First_Capitalized, Name_Case_Consistant, Name_Case_Any); subtype Abbreviation_Aves is Float; -- Physical Layout type Loop_Names_Needs is (Required, Average, not_Required); -- Transportability type Character_Set_Types is (Basic, Graphic, Extended); type Pragma_Classes is (All_Pragmas, System_Dependent, None); -- -- The following is probably to be located in the package body. -- type Package_Name_Node; -- type Package_List is access Package_Name_node; -- type Package_Name_Node is -- record -- P_Name : DYN.DYN_STRING; -- Next : Package_List; -- end record; -- Statement Use type Keyword_Use_Type is (No_Use, Restricted_Use, Free_Use); type Keyword_Use_Descript is record Use_Class : Keyword_Use_Type := Free_Use; Use_Freq : float := 0.0; end record; type Keyword_Uses is array( Tokenizer.keywords ) of Keyword_Use_descript; ------------------------------------- -- This procedure obtains the 'style ------------------------------------- Procedure Set_Style_Parameters; -- This sets the parameter variables. -------------------------------------------- -- These return style individual parameters -------------------------------------------- function Number_of_Errors_to_Report return natural; -- This returns a number telling how many times to list -- a error in the "Flaws" output. I.E. If this returns -- "3", then only the first three occurences of each -- type of error are listed. function OUTPUT_KEYWORD_LIST return Keyword_Options; -- This function returns a value specifying the output format for -- listing the reserved word usage. It specifys which class of -- reserved words to output, all keywords, only those keywords -- used or not used, keywords used in violation of style restrictions, -- or no keywords output. function OUTPUT_OPERATOR_LIST return boolean; -- This function returns true if the operator list is to be printed -- as part of the style report. function SMALL_PROGRAM_SIZE return natural; -- returns size of programs considered 'too small' so limits of -- some things may be violated with not penalty. function Small_Word_Size return Word_Lengths; -- returns size of words considered 'too small' so limits of -- some things may be violated with no penalty. function Small_Structure_Size return Natural; -- returns size (in statements) of structures considered 'too small' so -- some constraints may be violated with no penalty. function Case_of_Reserved_Words return Reserve_Word_Cases; function Case_of_Object_Names return Object_Name_Cases; function Average_Name_Size return Word_Lengths; -- The average size of names in the program should be greater than -- this minimum. function Is_Underscore_Required return boolean; function Average_Underscore_Size return Word_Lengths; -- If underscores are required and the word under inspection is -- longer than a "Small_Word", then the parts separated by -- underscores should be longer than this minimum. function Vowel_Frequency return float; -- To keep people from abbreviating too much, check the percentage of -- vowels to consonants. If (Vowel / Total-letters) is less than -- Vowel_Frequency percent, there is something wrong. function SPELLING_REQUIRED return Require_Type; -- This function returns 'Required' if the style checker is to -- send words to a spelling checker to validate variable names. function Is_One_Statement_per_line_Required return boolean; function Is_Declaration_Indentation_Required return boolean; -- Forced to indent properly on object, type declarations? function Is_Comment_Indentation_Required return boolean; -- Forced to indent the trailing comments after statement on a line? function Is_Blank_Lines_around_Blocks_Required return boolean; -- Should blank lines around blocks, loops, etc. be required? -- We deleted this function -- function Average_Blank_Lines return float; -- -- The average # of blank lines should be 'Ave-blank-lines' +- delta -- -- for readability's sake function Loop_Name_Required return Loop_Names_Needs; -- Are loop-names necessary, should loops of a certain size need names. procedure Reserved_Word_Info ( Usage : out Keyword_Uses ); function Average_Comment_Size return positive; -- To prevent style "tricking" comments must have a minimum average -- size; function Average_Literal_in_Body return float; -- Literals should be in the declaration rather then the body, so -- the number of literals in the body should be less than "ave-literal" function Average_Universal_Usage return float; -- In general, good use should be made of programmer-defined types -- rather than universal integer, float, etc. The percentage of -- types which are universal integer, float, natural, positive, etc. -- should be less then "ave-universals" function Is_Data_Structure_Use_Required return boolean; -- Should we check for enumeration types, records? function ATTRIBUTE_CHECK return Require_Type; -- This function tells whether the style checker notes the -- use of attributes. procedure Average_Subprogram_Size (SMALL_LIMIT : out natural; LARGE_LIMIT : out natural ); procedure SUBPROGRAM_PARAMETERS (SMALL_LIMIT : out natural; LARGE_LIMIT : out natural ); function CONTROL_NESTING_LEVEL return Natural; -- This is the expected depth of nesting of control structures. function PACKAGE_NESTING_LEVEL return Natural; -- This is the expected depth of nesting of packages. function SUBPROGRAM_NESTING_LEVEL return Natural; -- This is the expected depth of nesting of subprograms. function NUMBER_OF_LOOP_EXITS return natural; -- This number is a limit on the number of exits from a loop. function LINE_SIZE return natural; -- This number is a limit on the number of characters in a line. function CHARACTER_SET return Character_Set_Types; -- This enumeration type determines the characters which are -- not flagged as style errors. This is to limit use of -- graphic or extended characters which may not transport to -- other machines. function REPRESENTATION_SPECS_ALLOWED return boolean; -- This returns true if rep specs are allowed in the style. function ADDRESS_CLAUSE_ALLOWED return boolean; -- This returns true if address clauses are allowed in the style. function NOTE_PRAGMAS return Pragma_Classes; -- This is an enumeration type defining which pragmas (all, system- -- dependent, or none) are illegal as defined in the style function IS_A_PREDEFINED_PRAGMA (name : in DYN.DYN_STRING ) return boolean; -- This returns true if the input name is a predefined pragma as listed -- in the LRM appendix B. function IS_A_PROSCRIBED_PACKAGE (name : in DYN.DYN_STRING) return boolean; -- This returns true if the input name is a package on the -- list of 'stylistically incorrect' packages as defined by the style. end Style_Parameters; :::::::::: repgenspe.ada :::::::::: with TEXT_IO; with STYLE_PARAMETERS; with TOKENIZER; with DYN; package REPORT_GENERATOR is -------------------------------------------------------------------------- -- Abstract : This is the package that exports the types and routines -- necessary to create and write the two report files -- from the Style_Checker. -------------------------------------------------------------------------- type TOKEN_COUNT_ARRAY is array (TOKENIZER.TOKEN_TYPE) of NATURAL; type AVERAGE_KEEPING_RECORD is record NUMBER_OF_ITEMS : NATURAL := 0; TOTAL_SIZE_OF_ITEMS : NATURAL := 0; end record; type DATA_STRUCTURE_TYPES is (ARRAY_TYPES, ENUMERATION_TYPES, RECORD_TYPES); type DATA_STRUCTURE_TYPES_USED is array (DATA_STRUCTURE_TYPES) of BOOLEAN; type STRING_NODE; type STRING_LIST_TYPE is access STRING_NODE; type STRING_NODE is record NAME : DYN.DYN_STRING; NEXT : STRING_LIST_TYPE := null; end record; type CHARACTER_COUNT is array (CHARACTER) of NATURAL; type REPORT_RECORD is record -- Naming Conventions INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER : NATURAL := 0; INVALID_CASE_FOR_A_KEYWORD : NATURAL := 0; ABBREVIATIONS : BOOLEAN := FALSE; NAME_SEGMENT_SIZE_DESIRED_MAXIMUM : NATURAL := STYLE_PARAMETERS.AVERAGE_UNDERSCORE_SIZE; NAME_SEGMENT_SIZE_ACTUAL : FLOAT := 0.0; AVERAGE_NAME_SIZE_DESIRED_MINIMUM : NATURAL := STYLE_PARAMETERS.AVERAGE_NAME_SIZE; AVERAGE_NAME_SIZE_ACTUAL : FLOAT := 0.0; -- Physical Layout OCCURRENCES_OF_MORE_THAN_ONE_STATEMENT_PER_LINE : NATURAL := 0; INCONSISTANT_INDENTATION : NATURAL := 0; MISSING_BLANK_LINES_TO_SET_OFF_A_BLOCK : NATURAL := 0; MISSING_PROLOG : NATURAL := 0; LOOPS_WITHOUT_NAMES : NATURAL := 0; PERCENT_OF_BLANK_LINES_DESIRED_MINIMUM : FLOAT := 0.0; PERCENT_OF_BLANK_LINES_ACTUAL : FLOAT := 0.0; -- Information Hiding, Abstraction, Data Use PERCENT_OF_LITERALS_IN_BODY_DESIRED_MAXIMUM : FLOAT := STYLE_PARAMETERS.AVERAGE_LITERAL_IN_BODY; PERCENT_OF_LITERALS_IN_BODY_ACTUAL : FLOAT := 0.0; PERCENT_OF_UNIVERSAL_TYPES_DESIRED_MAXIMUM : FLOAT := STYLE_PARAMETERS.AVERAGE_UNIVERSAL_USAGE; PERCENT_OF_UNIVERSAL_TYPES_ACTUAL : FLOAT := 0.0; DATA_STRUCTURING_TYPES_NOT_USED : DATA_STRUCTURE_TYPES_USED := (DATA_STRUCTURE_TYPES'FIRST .. DATA_STRUCTURE_TYPES'LAST => TRUE); ATTRIBUTES_USED : BOOLEAN := FALSE; OR_ELSES_USED : BOOLEAN := FALSE; AND_THENS_USED : BOOLEAN := FALSE; EXITS_USED : BOOLEAN := FALSE; XORS_USED : BOOLEAN := FALSE; ELSIFS_USED : BOOLEAN := FALSE; EXCEPTIONS_USED : BOOLEAN := FALSE; INS_USED : BOOLEAN := FALSE; OUTS_USED : BOOLEAN := FALSE; IN_OUTS_USED : BOOLEAN := FALSE; PRIVATES_USED : BOOLEAN := FALSE; -- Modularity AVERAGE_NUMBER_OF_PARAMETERS_DESIRED_MINIMUM : NATURAL := 0; AVERAGE_NUMBER_OF_PARAMETERS_DESIRED_MAXIMUM : NATURAL := 0; INSTANCES_OF_PARAMETERS_BELOW_MINIMUM : NATURAL := 0; INSTANCES_OF_PARAMETERS_ABOVE_MAXIMUM : NATURAL := 0; AVERAGE_SUBPROGRAM_SIZE_DESIRED_MINIMUM : NATURAL := 0; AVERAGE_SUBPROGRAM_SIZE_DESIRED_MAXIMUM : NATURAL := 0; INSTANCES_OF_SIZE_BELOW_MINIMUM : NATURAL := 0; INSTANCES_OF_SIZE_ABOVE_MAXIMUM : NATURAL := 0; INSTANCES_OF_TOO_MANY_EXITS : NATURAL := 0; CONTROL_STRUCTURE_NESTING_DESIRED_MAXIMUM : NATURAL := STYLE_PARAMETERS.CONTROL_NESTING_LEVEL; CONTROL_STRUCTURE_NESTING_EXCEEDING_MAXIMUM : NATURAL := 0; PACKAGE_NESTING_DESIRED_MAXIMUM : NATURAL := STYLE_PARAMETERS.PACKAGE_NESTING_LEVEL; PACKAGE_NESTING_EXCEEDING_MAXIMUM : NATURAL := 0; SUBPROGRAM_NESTING_DESIRED_MAXIMUM : NATURAL := STYLE_PARAMETERS.SUBPROGRAM_NESTING_LEVEL; SUBPROGRAM_NESTING_EXCEEDING_MAXIMUM : NATURAL := 0; -- Comment Usage NUMBER_OF_COMMENTS : NATURAL := 0; AVERAGE_COMMENT_SIZE_DESIRED_MINIMUM : NATURAL := STYLE_PARAMETERS.AVERAGE_COMMENT_SIZE; AVERAGE_COMMENT_SIZE_ACTUAL : FLOAT := 0.0; -- Transportability NUMBER_OF_LINES_EXCEEDING_LINE_LENGTH : NATURAL := 0; GRAPHIC_CHARACTERS_USED : CHARACTER_COUNT := (CHARACTER'FIRST..CHARACTER'LAST => 0); NON_GRAPHIC_CHARACTERS_USED : CHARACTER_COUNT := (CHARACTER'FIRST..CHARACTER'LAST => 0); ADDRESS_CLAUSES : NATURAL := 0; REPRESENTATION_SPECIFICATIONS : NATURAL := 0; PRAGMAS_USED : STRING_LIST_TYPE := null; NON_STANDARD_PRAGMAS_USED : STRING_LIST_TYPE := null; PACKAGES_PROCEDURES_WITHED : STRING_LIST_TYPE := null; -- Keyword Usage KEYWORD_USAGE : STYLE_PARAMETERS.KEYWORD_USES; TOKEN_COUNT : TOKEN_COUNT_ARRAY := (TOKENIZER.TOKEN_TYPE'FIRST .. TOKENIZER.TOKEN_TYPE'LAST => 0); end record; type ERRORS is (INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER, INVALID_CASE_FOR_A_KEYWORD, ABBREVIATION, -- Physical Layout MORE_THAN_ONE_STATEMENT_ON_LINE, INCONSISTANT_INDENTATION, MISSING_BLANK_LINES_TO_SET_OFF_A_BLOCK, MISSING_PROLOG, LOOP_WITHOUT_NAME, -- Modularity TOO_FEW_PARAMETERS, TOO_MANY_PARAMETERS, SUBPROGRAM_SIZE_BELOW_MINIMUM, SUBPROGRAM_SIZE_ABOVE_MAXIMUM, TOO_MANY_EXITS, PACKAGE_NESTED_TOO_DEEP, CONTROL_STRUCTURE_NESTED_TOO_DEEP, SUBPROGRAM_NESTED_TOO_DEEP, -- Transportability LINE_EXCEEDING_LINE_LENGTH, GRAPHIC_CHARACTER_USED, NON_GRAPHIC_CHARACTER_USED, ADDRESS_CLAUSE_USED, REPRESENTATION_SPECIFICATION_USED, PRAGMA_USED, NON_STANDARD_PRAGMA_USED, -- Other UNMATCHED_NESTING, OTHER); procedure PUT_FLAW(TO_THIS : in TEXT_IO.FILE_TYPE; BAD_TOKEN : in TOKENIZER.TOKEN; ERROR_MESSAGE : in DYN.DYN_STRING; ERROR_TYPE : in ERRORS := OTHER ); procedure PUT_FLAW(TO_THIS : in TEXT_IO.FILE_TYPE; BAD_TOKEN : in TOKENIZER.TOKEN; ERROR_MESSAGE : in STRING; ERROR_TYPE : in ERRORS := OTHER ); procedure GENERATE_REPORT(FROM_THIS : in REPORT_RECORD; TO_THIS : in TEXT_IO.FILE_TYPE; FILE_NAME : in DYN.DYN_STRING ); procedure INSERT_INTO_LIST ( LIST : in out STRING_LIST_TYPE; ELEMENT : DYN.DYN_STRING ); end REPORT_GENERATOR; :::::::::: stackpack.ada :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : STACK_PACKAGE -- Author : Tom Duke -- Date created : Sept. 7, 1984 -- Last update : Sept. 20, 1984 -- -* ------------------------------------------------------------------------ -- -* -- Abstract : This is a generic package that provides the types, ----------------: procedures, and exceptions to define an abstract stack ----------------: and its corresponding operations. Using an ----------------: instantiation of this generic package, one can declare ----------------: multiple versions of a stack of type HELP_INFO_STACK. ----------------: The stack operations provided include: ----------------: 1. clear the stack, ----------------: 2. pop the stack, ----------------: 3. push an element onto the stack, and ----------------: 4. access the top element on the stack. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- generic type ELEMENTS is private; SIZE : POSITIVE; package STACK_PACKAGE is type HELP_INFO_STACK is private; function TOP_ELEMENT( STACK : in HELP_INFO_STACK ) return ELEMENTS; function STACK_IS_EMPTY( STACK : in HELP_INFO_STACK ) return BOOLEAN; procedure CLEAR_STACK( STACK : in out HELP_INFO_STACK ); procedure PUSH ( FRAME : in ELEMENTS; STACK : in out HELP_INFO_STACK ); procedure POP ( FRAME : out ELEMENTS; STACK : in out HELP_INFO_STACK ); NULL_STACK : exception; STACK_OVERFLOW : exception; STACK_UNDERFLOW : exception; private type STACK_LIST is array ( 1 .. SIZE ) of ELEMENTS; type HELP_INFO_STACK is record CONTENTS : STACK_LIST; TOP : NATURAL range NATURAL'FIRST .. SIZE := NATURAL'FIRST; end record; end STACK_PACKAGE; ------------------------------------------------------------------------- package body STACK_PACKAGE is --------------- -- function TOP_ELEMENT -- This function returns the value of the top -- element on the stack. It does not return a -- pointer to the top element. If the stack is empty, a constraint error -- occurs. The exception handler will then raise the NULL_STACK -- exception and pass it to the calling procedure. --------------- function TOP_ELEMENT( STACK : in HELP_INFO_STACK ) return ELEMENTS is begin return STACK.CONTENTS(STACK.TOP); exception when CONSTRAINT_ERROR => raise NULL_STACK; when others => raise; end TOP_ELEMENT; ---------- -- Is stack empty? ---------- function STACK_IS_EMPTY( STACK : in HELP_INFO_STACK ) return BOOLEAN is begin return (STACK.TOP = NATURAL'FIRST); exception when OTHERS => raise; end STACK_IS_EMPTY; --------------- -- procedure CLEAR_STACK -- This procedure resets the stack pointer, TOP, -- to a value representing an empty stack. --------------- procedure CLEAR_STACK( STACK : in out HELP_INFO_STACK ) is begin STACK.TOP := NATURAL'FIRST; end CLEAR_STACK; --------------- -- procedure PUSH -- This procedure attempts to push another element onto -- the stack. If the stack is full, a constraint error -- occurs. The exception handler will then raise the STACK_OVERFLOW -- exception and pass it to the calling procedure. --------------- procedure PUSH ( FRAME : in ELEMENTS; STACK : in out HELP_INFO_STACK ) is begin STACK.TOP := STACK.TOP + 1; STACK.CONTENTS(STACK.TOP) := FRAME; exception when CONSTRAINT_ERROR => raise STACK_OVERFLOW; when others => raise; end PUSH; --------------- -- procedure POP -- This procedure attempts to pop an element from -- the stack. If the stack is empty, a constraint error -- occurs. The exception handler will then raise the STACK_UNDERFLOW -- exception and pass it to the calling procedure. --------------- procedure POP ( FRAME : out ELEMENTS; STACK : in out HELP_INFO_STACK ) is begin FRAME := STACK.CONTENTS(STACK.TOP); STACK.TOP := STACK.TOP - 1; exception when CONSTRAINT_ERROR => raise STACK_UNDERFLOW; when others => raise; end POP; end STACK_PACKAGE; :::::::::: tokendefi.ada :::::::::: -- -- Token-Specific Information for the Spelling Checker -- package TOKEN_DEFINITION is -------------------------------------------------------------------------- -- Abstract : TOKEN_DEFINITION contains the definition of a token -- (see type TOKEN_TYPE), including the length of its -- word which may be easily changed (see TOKEN_LENGTH). -- -- IS_SPECIAL_CHAR is also provided since it is a commonly- -- used routine which is employed by more than one package. -------------------------------------------------------------------------- -- -- Definition of a Token (Word) -- TOKEN_LENGTH : constant NATURAL := 25; -- number of characters subtype TOKEN_STRING is STRING (1 .. TOKEN_LENGTH); type TOKEN_TYPE is record WORD : TOKEN_STRING; LENGTH : NATURAL; end record; function IS_SPECIAL_CHAR (CH : CHARACTER) return BOOLEAN; -------------------------------------------------------------------------- -- Abstract : Returns a BOOLEAN indicating if the indicated character -- is one of the special characters which may be found -- within a word or at the end of a word. -------------------------------------------------------------------------- -- Parameters : CH - character to test -------------------------------------------------------------------------- end TOKEN_DEFINITION; package body TOKEN_DEFINITION is SPECIAL_CHARS : constant STRING (1 .. 3) := "-'."; function IS_SPECIAL_CHAR (CH : CHARACTER) return BOOLEAN is begin for I in SPECIAL_CHARS'FIRST .. SPECIAL_CHARS'LAST loop if CH = SPECIAL_CHARS (I) then return TRUE; end if; end loop; return FALSE; end IS_SPECIAL_CHAR; end TOKEN_DEFINITION; :::::::::: manager.ada :::::::::: ------------------------------------------------------------ -- -- Abstract : This unit outlines the procedures and functions -- : contained in this package. The visible section -- : provides the interfaces necessary for commun- -- : ication with the various subunits contained in -- : the package. -- : -- : The package is concerned with the handling of the -- : data structures that are utilized for the storage of the -- : information, (words and acronyms), which is used -- : within the Spelling Corrector tool. -- ---------------------------------------------------------------- with TEXT_IO, TOKEN_DEFINITION; package DICTIONARY_MANAGER is --Establishes the types of dictionaries available type DICTIONARY_TYPE is (MASTER,ACRONYM,USER); type DICTIONARY_PTR is private; subtype FILE_NAME_TYPE is TEXT_IO.FILE_TYPE; --A test variable to be removed later WORD_COUNTER : NATURAL; -- NO_MORE_WORDS : exception; --raised when the NEXT_WORD --procedure can no longer return --the required number of words or --the procedure is called with a --word count of 0 BAD_WORD : exception; --An illegal word format --raised in the HASH_VALUE function DICTIONARY_ERROR : exception; --A nonexistent dictionary --or dictionary error WORD_NOT_VALID : exception; --A word not in the dictionary --raised in the DELETE_WORD procedure HARDWARE_FAILURE : exception; --Failure of IO devices -- The following procedures and functions are documented in the -- package body (DICTIONARY_MANAGER) procedure CREATE_DICTIONARY(DICTIONARY_KIND : in DICTIONARY_TYPE; DICTIONARY_IN : out DICTIONARY_PTR; FILENAME : in STRING); procedure TOKEN_IS_FOUND(IN_DICTIONARY : out DICTIONARY_PTR; WORD : in TOKEN_DEFINITION.TOKEN_TYPE; FOUND : out BOOLEAN); private type WORD_RECORD; type WORD_RECORD_PTR is access WORD_RECORD; type WORD_RECORD is record TOKEN : TOKEN_DEFINITION.TOKEN_TYPE; NEXT : WORD_RECORD_PTR; end record; MAX_HASH_BUCKETS : constant POSITIVE := 101; subtype HASH_BUCKET_TYPE is POSITIVE range POSITIVE'FIRST..MAX_HASH_BUCKETS; type DICTIONARY_HASH_STRUCTURE is array (HASH_BUCKET_TYPE) of WORD_RECORD_PTR; type DICTIONARY_RECORD; type DICTIONARY_PTR is access DICTIONARY_RECORD; type DICTIONARY_RECORD is record DICTIONARY_NAME : DICTIONARY_TYPE; ENABLED : BOOLEAN := FALSE; HASH_TABLE : DICTIONARY_HASH_STRUCTURE; NEXT_DICTIONARY : DICTIONARY_PTR; ALTER_FLAG : BOOLEAN := FALSE; end record; end DICTIONARY_MANAGER; ---------------------------------------------------------------- -- -- Abstract : This unit is the STUB for the dictionary manager -- ---------------------------------------------------------------- package body DICTIONARY_MANAGER is procedure CREATE_DICTIONARY(DICTIONARY_KIND : in DICTIONARY_TYPE; DICTIONARY_IN : out DICTIONARY_PTR; FILENAME : in STRING) is begin return; end CREATE_DICTIONARY; procedure TOKEN_IS_FOUND(IN_DICTIONARY : out DICTIONARY_PTR; WORD : in TOKEN_DEFINITION.TOKEN_TYPE; FOUND : out BOOLEAN) is begin FOUND := TRUE; end TOKEN_IS_FOUND; end DICTIONARY_MANAGER; :::::::::: helpfiles.ada :::::::::: package HELP is -------------------------------------------------------------------------- -- Abstract : This is a help package. It gives access to a help routine -- that can be called from the Style_Checker. -------------------------------------------------------------------------- subtype LEVEL_TYPE is string(1..4) ; HELP : constant LEVEL_TYPE := "HELP"; procedure HELP_SCREEN (LEVEL : LEVEL_TYPE; HELP_FILE_NAME : string); -- exceptions HELP_OPEN_ERROR : exception; HELP_FILE_ERROR : exception; HELP_FORMAT_ERROR : exception; end HELP; :::::::::: commandli.ada :::::::::: -- -- COMMAND_LINE_HANDLER by Richard Conn, TI Ada Technology Branch -- 27 Feb 85 -- package COMMAND_LINE_HANDLER is -------------------------------------------------------------------------- -- Abstract : This package contains routines which return words -- from the command line tail (parameters following -- the command line verb). It expects a file to have -- been created externally which contains these words, -- one word per line. -------------------------------------------------------------------------- NO_COMMAND_LINE_FILE : exception; NO_MORE_WORDS : exception; procedure NEXT_WORD (COMMAND_LINE_FILE_NAME : in STRING; WORD : out STRING; LENGTH : out NATURAL); -------------------------------------------------------------------------- -- Abstract : NEXT_WORD returns the next word from the command -- line tail. If there are no more words, NO_MORE_WORDS -- is raised. If there is no command line file, -- NO_COMMAND_LINE_FILE is raised. -------------------------------------------------------------------------- -- Parameters : WORD - string containing the next word -- LENGTH - number of chars in next word -------------------------------------------------------------------------- procedure RESET; -------------------------------------------------------------------------- -- Abstract : If the file containing the command line's words -- is open, this file is closed. The net effect is -- that the next invocation of NEXT_WORD will return -- the first word of the command line tail. -------------------------------------------------------------------------- end COMMAND_LINE_HANDLER; with TEXT_IO; package body COMMAND_LINE_HANDLER is COMMAND_FILE : TEXT_IO.FILE_TYPE; procedure RESET is begin if TEXT_IO.IS_OPEN (COMMAND_FILE) then TEXT_IO.CLOSE (COMMAND_FILE); end if; end RESET; procedure NEXT_WORD (COMMAND_LINE_FILE_NAME : in STRING; WORD : out STRING; LENGTH : out NATURAL) is begin if not TEXT_IO.IS_OPEN (COMMAND_FILE) then begin TEXT_IO.OPEN (COMMAND_FILE, TEXT_IO.IN_FILE, COMMAND_LINE_FILE_NAME); exception when others => raise NO_COMMAND_LINE_FILE; end; end if; TEXT_IO.GET_LINE (COMMAND_FILE, WORD, LENGTH); exception when NO_COMMAND_LINE_FILE => raise; when others => raise NO_MORE_WORDS; end NEXT_WORD; end COMMAND_LINE_HANDLER; :::::::::: helpspec.ada :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : HELP_UTILITY spec -- Author : BASKETTE -- Date created : 28 January 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : VAX like HELP Utility. Thera are three procedures: ----------------: 1) Initialize - reads the help file into a data structure ----------------: 2) Help_Me - the help driver ----------------: 3) Terminate_help - terminates the help utility ----------------: ----------------: A function is provided to check if help is active -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- package HELP_UTILITY is ILLEGAL_FORMAT_FOR_HELP_FILE: exception; HELP_FILE_DOES_NOT_EXIST: exception; CANNOT_OPEN_HELP_FILE: exception; HELP_FILE_NOT_INITIALIZED: exception; NOTHING_TO_OUTPUT: exception; procedure INITIALIZE(HELP_FILE_NAME: in string); procedure HELP_ME(CLI_BUFFER: in string); procedure GET_TEXT_LINE(LINE: out string; CHAR_COUNT: out natural; IS_LAST: out boolean); procedure EXIT_HELP; procedure RESET_HELP; function HELP_IS_TERMINATED return boolean; end HELP_UTILITY; :::::::::: HELPINFOS.ADA :::::::::: ------------------------------------------------------------------------ -- -* -- Abstract : The HELP_INFO_SUPPORT package provides the constants ----------------: and types to support the implementation of the AIM ----------------: Help and Info utilities. -- -* ------------------------------------------------------------------------ package HELP_INFO_SUPPORT is MAX_LINE_LENGTH : constant INTEGER := 80; MAX_LEVEL : constant INTEGER := 10; TOKEN_SEPARATER : constant CHARACTER := ' '; -- types and pointers for APPEND_TO_DISPLAY ------------ subtype FILE_TEXT_LINE is string(1..MAX_LINE_LENGTH); type TEXT_LINE; type TEXT_LINK is access TEXT_LINE; type TEXT_LINE is record TEXT_LINE : FILE_TEXT_LINE; LINE_LENGTH : natural := 0; NEXT_LINE : TEXT_LINK := null; end record; TOP_LINE: TEXT_LINK := new TEXT_LINE; CURRENT_LINE: TEXT_LINK := TOP_LINE; PREVIOUS_LINE: TEXT_LINK := TOP_LINE; IS_FIRST_TIME: boolean := true; ----------------------------------------------------------- subtype LEVEL_RANGE is NATURAL range 0..MAX_LEVEL; subtype HELP_INFO_TEXT_LINE is STRING(1..MAX_LINE_LENGTH); ---------- -- type declarations for the parsed input buffer ---------- subtype LINE_LENGTH is NATURAL range 0..MAX_LINE_LENGTH; subtype LINE_INDEX is POSITIVE range 1..MAX_LINE_LENGTH; type TOKEN_RECORD is record TOKEN : HELP_INFO_TEXT_LINE; LENGTH : LINE_LENGTH; BUFFER_POS : POSITIVE; -- 1..aim_support.max_data_length end record; subtype NUMBER_OF_TOKENS_RANGE is NATURAL range 0..MAX_LEVEL; subtype TOKEN_ARRAY_RANGE is POSITIVE range 1..MAX_LEVEL; type TOKEN_ARRAY is array( TOKEN_ARRAY_RANGE ) of TOKEN_RECORD; ---------- -- Subtype and type which define the structure of the table used -- for implicit conversion of characters from lowercase to uppercase. ---------- subtype LOWER_CASE_RANGE is CHARACTER range ASCII.LC_A .. ASCII.LC_Z; type CASE_CONVERSION_TABLE is array( LOWER_CASE_RANGE ) of CHARACTER; ---------- -- Variables used when working with the INPUT_TOKEN_TABLE. ---------- TOKEN_LENGTH : LINE_LENGTH; TOKEN_STRING : HELP_INFO_TEXT_LINE; TOKEN_POS : POSITIVE; ---------- -- Pointer to the next character position of the user input string -- to be accessed during the procedures PARSE and GET_NEXT_INFO_TOKEN. ---------- INPUT_STRING_POS : POSITIVE; ---------- -- Table used to store individual tokens, their length, and their -- position in the user's input string. ---------- INPUT_TOKEN_TABLE : TOKEN_ARRAY; ---------- -- Counter for saving the number of tokens extracted from the user's -- input string. ---------- NUMBER_OF_TOKENS : NUMBER_OF_TOKENS_RANGE; ---------- -- As the variable type indicates, the case conversion table used -- for implicit conversion from lowercase to uppercase. ---------- UPPER_CASE : CASE_CONVERSION_TABLE := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; KEYWORD_NOT_FOUND : exception; ----------------------------------------------------------- procedure APPEND_TO_DISPLAY(LINE : in STRING; CHAR_COUNT: in natural); procedure IDENTIFY_KEYWORD( TOKEN_STRING : in HELP_INFO_TEXT_LINE; TOKEN_LENGTH : in LINE_LENGTH; KEYWORD : in HELP_INFO_TEXT_LINE ); procedure GET_NEXT_TOKEN( INPUT_STRING : in STRING; NEXT_STRING : out HELP_INFO_TEXT_LINE; NEXT_LENGTH : out LINE_LENGTH; NEXT_POS : out POSITIVE ); procedure PARSE(INPUT_STRING : in STRING); end HELP_INFO_SUPPORT; :::::::::: HELPINFOB.ADA :::::::::: ------------------------------------------------------------------------ -- -* -- Abstract : The HELP_INFO_SUPPORT package provides the constants ----------------: and types to support the implementation of the AIM ----------------: Help and Info utilities. -- -* ------------------------------------------------------------------------ package body HELP_INFO_SUPPORT is procedure APPEND_TO_DISPLAY(LINE : in STRING; CHAR_COUNT: in natural) is begin if LINE'length <= FILE_TEXT_LINE'length then CURRENT_LINE.TEXT_LINE := FILE_TEXT_LINE'(others => ' '); CURRENT_LINE.TEXT_LINE(1..LINE'length) := LINE; CURRENT_LINE.LINE_LENGTH := CHAR_COUNT; else CURRENT_LINE.TEXT_LINE := LINE(1..FILE_TEXT_LINE'length); CURRENT_LINE.LINE_LENGTH := FILE_TEXT_LINE'length; end if; PREVIOUS_LINE.NEXT_LINE := CURRENT_LINE; CURRENT_LINE.NEXT_LINE := null; PREVIOUS_LINE := CURRENT_LINE; CURRENT_LINE := new TEXT_LINE; exception when others => raise; end APPEND_TO_DISPLAY; ---------- -- The procedure IDENTIFY_KEYWORD compares the parameter TOKEN_STRING -- to the parameter KEYWORD in an -- attempt to identify a match. The global array UPPER_CASE is used -- to convert the input character to upper case for comparison purposes. -- Note that the input token string actually remains unchanged. -- The logic assumes that if the character position pointer TEST_POS -- is incremented past the value of the parameter TOKEN_LENGTH (the -- actual length of the input token string) then the TOKEN_STRING must -- be valid. This logic allows for abbreviations as small as one character -- to be identified. -- If a character mismatch or the CONSTRAINT_ERROR exception is raised, -- the exception KEYWORD_NOT_FOUND is raised. ---------- procedure IDENTIFY_KEYWORD( TOKEN_STRING : in HELP_INFO_TEXT_LINE; TOKEN_LENGTH : in LINE_LENGTH; KEYWORD : in HELP_INFO_TEXT_LINE ) is TEST_POS : POSITIVE; -- character test position DONE : BOOLEAN; begin TEST_POS := 1; DONE := FALSE; while TEST_POS <= TOKEN_LENGTH and then not DONE loop case TOKEN_STRING(TEST_POS) is when LOWER_CASE_RANGE => if UPPER_CASE(TOKEN_STRING(TEST_POS)) = KEYWORD(TEST_POS) then TEST_POS := TEST_POS + 1; else DONE := TRUE; end if; when others => if TOKEN_STRING(TEST_POS) = KEYWORD(TEST_POS) then TEST_POS := TEST_POS + 1; else DONE := TRUE; end if; end case; end loop; if TEST_POS <= TOKEN_LENGTH then raise KEYWORD_NOT_FOUND; end if; exception when CONSTRAINT_ERROR => raise KEYWORD_NOT_FOUND; when KEYWORD_NOT_FOUND => raise; when others => raise; end IDENTIFY_KEYWORD; ---------- -- The procedure GET_NEXT_TOKEN extracts, from INPUT_STRING, the -- next character(s) bounded by a -- valid token separater and another valid token separater or the end -- of the string. This procedure assumes that INPUT_STRING_POS is -- currently positioned between tokens (pointing at a separater -- character) or is positioned at the first character of some token in -- the INPUT_STRING. -- The exception CONSTRAINT_ERROR will be raised when the global -- variable INPUT_STRING_POS (of type POSITIVE) -- is greater than the length of INPUT_STRING. Therefore, this -- exception is not propagated upward but, is handled to identify the -- last token in the INPUT_STRING and its length. -- The expected format of INPUT_STRING is: -- -- [^^^]AAA[^^^AAA...][^^^][<CR>] -- -- where -- ^^^ represents any number of separaters (spaces or less), -- -- AAA represents any number of characters greater than spaces, -- -- ... indicates the preceeding pattern may be repeated, -- -- [ ] indicates an optional entry in the string, -- -- <CR> represents the string delimiter, -- normally ASCII.CR or ASCII.LF. -- ---------- procedure GET_NEXT_TOKEN( INPUT_STRING : in STRING; NEXT_STRING : out HELP_INFO_TEXT_LINE; NEXT_LENGTH : out LINE_LENGTH; NEXT_POS : out POSITIVE ) is TEST_POS : LINE_INDEX; -- character test position TEMP_STRING : HELP_INFO_TEXT_LINE := (others => ' '); begin TEST_POS := 1; ---------- -- Find first non-separater character. Will raise CONSTRAINT_ERROR -- if INPUT_STRING has trailing spaces with no delimiter. The -- exception block correctly handles this situation. ---------- NEXT_POS := INPUT_STRING_POS; while INPUT_STRING_POS <= INPUT_STRING'last and then INPUT_STRING(INPUT_STRING_POS) <= TOKEN_SEPARATER loop INPUT_STRING_POS := INPUT_STRING_POS + 1; end loop; NEXT_POS := INPUT_STRING_POS; ---------- -- Extract next token string from input buffer. A string delimiter, -- normally ASCII.CR or ASCII.LF, is expected after the last token. -- If no delimiter exists, a CONSTRINT_ERROR will be raised at the -- end of the last token in the string. ---------- while INPUT_STRING_POS <= INPUT_STRING'last and then INPUT_STRING(INPUT_STRING_POS) > TOKEN_SEPARATER loop TEMP_STRING(TEST_POS) := INPUT_STRING(INPUT_STRING_POS); TEST_POS := TEST_POS + 1; INPUT_STRING_POS := INPUT_STRING_POS + 1; end loop; NEXT_LENGTH := TEST_POS - 1; NEXT_STRING := TEMP_STRING; exception when CONSTRAINT_ERROR => NEXT_LENGTH := 0; -- throw away last token NEXT_STRING := TEMP_STRING; when others => raise; end GET_NEXT_TOKEN; ---------- -- The procedure PARSE calls the procedure GET_NEXT_TOKEN to extract -- individual tokens from the parameter INPUT_STRING -- and places these tokens in the INPUT_TOKEN_TABLE along with their -- length and position within the INPUT_STRING. -- The exception CONSTRAINT_ERROR is trapped to prevent a premature -- exit from the info utility. This exception will occur if the user -- entered more than the allowable number of tokens, as defined by the -- subtype TOKEN_ARRAY_RANGE. -- It is expected that INPUT_STRING will not contain characters with -- an ascii code less than TOKEN_SEPARATER (space character) except for -- ASCII.HT (between tokens only) and ASCII.CR or ASCII.LF (possible -- string delimiters). If any other character less than TOKEN_SEPARATER -- is encountered, the character is treated as a string delimiter. ---------- procedure PARSE(INPUT_STRING : in STRING) is begin NUMBER_OF_TOKENS := 0; INPUT_STRING_POS := 1; TOKEN_LENGTH := 1; while INPUT_STRING_POS <= INPUT_STRING'LENGTH and then TOKEN_LENGTH > 0 loop GET_NEXT_TOKEN(INPUT_STRING, TOKEN_STRING, TOKEN_LENGTH, TOKEN_POS); if TOKEN_LENGTH > 0 and then NUMBER_OF_TOKENS < MAX_LEVEL then NUMBER_OF_TOKENS := NUMBER_OF_TOKENS + 1; INPUT_TOKEN_TABLE(NUMBER_OF_TOKENS).TOKEN := TOKEN_STRING; INPUT_TOKEN_TABLE(NUMBER_OF_TOKENS).LENGTH := TOKEN_LENGTH; INPUT_TOKEN_TABLE(NUMBER_OF_TOKENS).BUFFER_POS := TOKEN_POS; else exit; end if; end loop; -- exception -- when CONSTRAINT_ERROR => -- occurs when NUMBER_OF_TOKENS > MAX_LEVEL -- null; -- when others => -- raise; end PARSE; end HELP_INFO_SUPPORT; :::::::::: HELPBODY.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : HELP_UTILITY body -- Author : Baskette -- Date created : 28 January 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : Body for the HELP Utility ----------------: Contains the data strucutures and procedures used in the ----------------: help utility other than those in the support package. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- with TEXT_IO; with HELP_INFO_SUPPORT; use HELP_INFO_SUPPORT; package body HELP_UTILITY is -- Text File for Help Utility HELP_FILE_TYPE: text_io.file_type; -- Tree Data Structures type HELP_TOPIC; type HELP_LINK is access HELP_TOPIC; type HELP_TOPIC is record NAME : FILE_TEXT_LINE; NAME_LENGTH : positive := 1; LEVEL : natural := 1; TEXT_LINES : HELP_INFO_SUPPORT.TEXT_LINK := null; SUBTOPICS : HELP_LINK := null; -- link to first subtopic PARENT : HELP_LINK := null; -- link to parent record NEXT_TOPIC : HELP_LINK := null; -- link to next on same level end record; -- other common needs TOP_NODE : HELP_LINK := new HELP_TOPIC; CURRENT_NODE: HELP_LINK := null; OUTPUT_LINE: HELP_INFO_SUPPORT.HELP_INFO_TEXT_LINE; BLANK_LINE : HELP_INFO_TEXT_LINE := (1..HELP_INFO_SUPPORT.MAX_LINE_LENGTH =>' '); HEADER_LINE: constant string := "Information Available:"; ADD_HEADER_LINE: constant string := "Additional Information Available:"; TERM_LINE: constant string := "Help Terminated"; TOPIC_LINE: constant string := "topic? "; SUBTOPIC_LINE: constant string := "subtopic? "; NO_DOC_LINE: constant string := "Sorry, no documentation available on "; HELP_MODE: boolean := false; FIRST_HELP_ME_CALL: boolean := true; INITIALIZED: boolean := false; -- Procedures procedure INITIALIZE(HELP_FILE_NAME: in string) is separate; procedure FIND_KEYWORD(NODE_NAME: in string; NODE_NAME_LENGTH: in natural; NODE: in HELP_LINK; KEYWORD_MATCHES: out HELP_LINK; MATCH_COUNT: in out natural) is separate; procedure PRINT_TOPIC_MENU(NODE: in HELP_LINK) is separate; procedure PRINT_TOPIC_TEXT(NODE: in HELP_LINK) is separate; procedure PRINT_CURRENT_PROMPT(NODE: in HELP_LINK) is separate; procedure DISPLAY_ALL_HELP_INFO(NODE: in HELP_LINK) is separate; procedure HELP_ME(CLI_BUFFER: in string) is separate; procedure GET_TEXT_LINE(LINE: out string; CHAR_COUNT: out natural; IS_LAST: out boolean) is separate; procedure EXIT_HELP is separate; procedure RESET_HELP is separate; function HELP_IS_TERMINATED return boolean is begin if HELP_MODE then return false; else return true; end if; end HELP_IS_TERMINATED; end HELP_UTILITY; :::::::::: HELPDISAL.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : DISPLAY_ALL_HELP_INFO -- Date created : 28 January 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : This procedure prints all information under the ----------------: given node including text and menu. ----------------: It traverses the tree using recursion. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- separate(HELP_UTILITY) procedure DISPLAY_ALL_HELP_INFO(NODE: in HELP_UTILITY.HELP_LINK) is BLANK_LINE_LENGTH: constant natural := 0; begin HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_UTILITY.OUTPUT_LINE := HELP_UTILITY.BLANK_LINE; HELP_UTILITY.OUTPUT_LINE(1..NODE.NAME_LENGTH) := NODE.NAME(1..NODE.NAME_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.OUTPUT_LINE, NODE.NAME_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_UTILITY.PRINT_TOPIC_TEXT(NODE); if NODE.SUBTOPICS /= null then HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.ADD_HEADER_LINE, HELP_UTILITY.ADD_HEADER_LINE'length); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_UTILITY.PRINT_TOPIC_MENU(NODE); end if; -- go down subtopics link first if NODE.SUBTOPICS /= null then DISPLAY_ALL_HELP_INFO(NODE.SUBTOPICS); end if; -- go down next topic link last if NODE.NEXT_TOPIC /= null then DISPLAY_ALL_HELP_INFO(NODE.NEXT_TOPIC); end if; end DISPLAY_ALL_HELP_INFO; :::::::::: HELPEXIT.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : EXIT_HELP -- Date created : 28 January 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : The procedure sets the help mode flag to false and ----------------: resets the current node pointer to the top node of the ----------------: tree. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- separate (HELP_UTILITY) procedure EXIT_HELP is begin HELP_UTILITY.CURRENT_NODE := HELP_UTILITY.TOP_NODE; -- reset HELP_MODE to off HELP_UTILITY.HELP_MODE := false; HELP_UTILITY.FIRST_HELP_ME_CALL := TRUE; end EXIT_HELP; :::::::::: HELPFIND.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : FIND_KEYWORD -- Date created : 28 January 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : This procedure will return a node (list of nodes) that ----------------: potentially matches the given name. A count is returned ----------------: of the number of matches. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- separate (HELP_UTILITY) procedure FIND_KEYWORD (NODE_NAME: in string; NODE_NAME_LENGTH: in natural; NODE: in HELP_UTILITY.HELP_LINK; KEYWORD_MATCHES: out HELP_UTILITY.HELP_LINK; MATCH_COUNT: in out natural) is KEYWORD_NODE: HELP_UTILITY.HELP_LINK := null; PREV_NODE: HELP_UTILITY.HELP_LINK := null; CURR_NODE: HELP_UTILITY.HELP_LINK := null; TOP: HELP_UTILITY.HELP_LINK := CURR_NODE; begin KEYWORD_NODE := NODE.SUBTOPICS; MATCH_COUNT := 0; -- loop through all subtopics of current level and save any potential matches while KEYWORD_NODE /= null loop begin -- make the procedure call with input and subtopic name HELP_INFO_SUPPORT.IDENTIFY_KEYWORD( NODE_NAME, NODE_NAME_LENGTH, KEYWORD_NODE.NAME); -- if a match is found, control returns to here, else exception is raised -- save the match (could be partial match) CURR_NODE := new HELP_UTILITY.HELP_TOPIC; CURR_NODE.all := KEYWORD_NODE.all; if PREV_NODE = null then TOP := CURR_NODE; else PREV_NODE.NEXT_TOPIC := CURR_NODE; end if; PREV_NODE := CURR_NODE; MATCH_COUNT := MATCH_COUNT + 1; -- if a match is not made then exception is raised exception when KEYWORD_NOT_FOUND => null; end; KEYWORD_NODE := KEYWORD_NODE.NEXT_TOPIC; end loop; KEYWORD_MATCHES := TOP; -- other exceptions handled here exception when others => raise; end FIND_KEYWORD; :::::::::: HELPGET.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : GET_TEXT_LINE -- Date created : 20 Febrauary 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : This procedure allows the user of the HELP_UTILITY -- : to print the data accumulated by HELP_ME; -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- separate (HELP_UTILITY) procedure GET_TEXT_LINE (LINE: out string; CHAR_COUNT: out natural; IS_LAST: out boolean) is IS_LAST_TIME: boolean := false; LAST_CHAR_POS: natural := 0; begin IS_LAST := false; if HELP_INFO_SUPPORT.TOP_LINE = null then raise HELP_UTILITY.NOTHING_TO_OUTPUT; else if HELP_INFO_SUPPORT.IS_FIRST_TIME then HELP_INFO_SUPPORT.CURRENT_LINE := HELP_INFO_SUPPORT.TOP_LINE; HELP_INFO_SUPPORT.IS_FIRST_TIME := false; end if; if LINE'length > HELP_INFO_SUPPORT.CURRENT_LINE.LINE_LENGTH then LINE := (1..LINE'length => ' '); LINE(1..HELP_INFO_SUPPORT.CURRENT_LINE.LINE_LENGTH) := HELP_INFO_SUPPORT.CURRENT_LINE. TEXT_LINE(1..HELP_INFO_SUPPORT.CURRENT_LINE.LINE_LENGTH); CHAR_COUNT := HELP_INFO_SUPPORT.CURRENT_LINE.LINE_LENGTH; else LINE := HELP_INFO_SUPPORT.CURRENT_LINE.TEXT_LINE (1..LINE'length); CHAR_COUNT := LINE'length; end if; if HELP_INFO_SUPPORT.CURRENT_LINE.NEXT_LINE = null then HELP_INFO_SUPPORT.CURRENT_LINE := HELP_INFO_SUPPORT.TOP_LINE; IS_LAST := true; IS_LAST_TIME := true; else HELP_INFO_SUPPORT.CURRENT_LINE := HELP_INFO_SUPPORT.CURRENT_LINE.NEXT_LINE; end if; end if; if IS_LAST_TIME then HELP_INFO_SUPPORT.CURRENT_LINE := HELP_INFO_SUPPORT.TOP_LINE; HELP_INFO_SUPPORT.PREVIOUS_LINE := HELP_INFO_SUPPORT.TOP_LINE; HELP_INFO_SUPPORT.IS_FIRST_TIME := true; end if; exception when HELP_UTILITY.NOTHING_TO_OUTPUT => raise; when others => raise; end GET_TEXT_LINE; :::::::::: HELPINIT.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : INITIALIZE -- Date created : 28 January 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : This procedure reads in the specified help file into a ----------------: data structure (linked list). Comments are ignored. Any ----------------: input line starting with a digit is considered a new ----------------: level. All other lines are considered text lines. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- separate (HELP_UTILITY) procedure INITIALIZE(HELP_FILE_NAME: in string) is PREVIOUS_NODE : HELP_UTILITY.HELP_LINK := TOP_NODE; PREVIOUS_LINE : HELP_INFO_SUPPORT.TEXT_LINK := null; CURRENT_LINE : HELP_INFO_SUPPORT.TEXT_LINK := null; CURRENT_LEVEL : integer := 1; -- current topic level TOKEN_IS_DIGITS : boolean := false; -- indicates if new record FIRST_DIGIT_FOUND : boolean := false; -- topic must be before text LINE_BUFFER : HELP_INFO_SUPPORT.FILE_TEXT_LINE; LAST : natural := 0; -- # of characters in LINE_BUFFER FIRST_TEXT_CHAR : natural := 0; -- first non-digit character -- exception TEXT_FILE_LEVEL_BAD : exception; TEXT_BEFORE_TOPIC : exception; begin HELP_UTILITY.HELP_MODE := true; HELP_UTILITY.FIRST_HELP_ME_CALL := true; text_io.open (HELP_UTILITY.HELP_FILE_TYPE, -- open the help file text_io.in_file, HELP_FILE_NAME, ""); while not text_io.end_of_file (HELP_UTILITY.HELP_FILE_TYPE) loop -- blank the input buffer before using LINE_BUFFER := HELP_UTILITY.BLANK_LINE; text_io.get_line (HELP_UTILITY.HELP_FILE_TYPE, LINE_BUFFER, LAST); -- Check if comment input. If so, skip the record. if LINE_BUFFER(LINE_BUFFER'first) = '-' and then LINE_BUFFER(LINE_BUFFER'first+1) = '-' then null; -- comment read, ignore it else -- Check if new topic read, i.e., digit is first character of record. if LINE_BUFFER (LINE_BUFFER'first) in '0' .. '9' then TOKEN_IS_DIGITS := true; FIRST_DIGIT_FOUND := true; FIRST_TEXT_CHAR := 1; -- loop until all digits found while LINE_BUFFER(FIRST_TEXT_CHAR) in '0' .. '9' and FIRST_TEXT_CHAR < HELP_INFO_SUPPORT.MAX_LINE_LENGTH loop FIRST_TEXT_CHAR := FIRST_TEXT_CHAR + 1; end loop; -- convert to integer value CURRENT_LEVEL := integer'value(LINE_BUFFER (LINE_BUFFER'first .. FIRST_TEXT_CHAR - 1)) - integer'value ("0"); -- skip any blanks between level and keyword while LINE_BUFFER(FIRST_TEXT_CHAR) = ' ' loop FIRST_TEXT_CHAR := FIRST_TEXT_CHAR + 1; end loop; end if; if TOKEN_IS_DIGITS then -- NEW TOPIC: -- Tree structure note: SUBTOPICS links are for children -- NEXT_TOPIC links are for siblings -- TOP_NODE is the Papa/Mama node -- Three cases: -- 1) Current topic level is greater than previous topic level -- (current is subtopic of previous) -- 2) Current topic level is less than previous topic level -- 3) Current topic level is same as previous (or default when first) PREVIOUS_LINE := null; HELP_UTILITY.CURRENT_NODE := new HELP_UTILITY.HELP_TOPIC ; if CURRENT_LEVEL > PREVIOUS_NODE.LEVEL then -- CASE 1: Current topic level is greater than previous topic level -- Set double links -- check that level increases by only one if CURRENT_LEVEL - PREVIOUS_NODE.LEVEL > 1 then raise TEXT_FILE_LEVEL_BAD; end if; PREVIOUS_NODE.SUBTOPICS := HELP_UTILITY.CURRENT_NODE; HELP_UTILITY.CURRENT_NODE.PARENT := PREVIOUS_NODE; elsif CURRENT_LEVEL < PREVIOUS_NODE.LEVEL then -- CASE 2: Current topic level is less than previous topic level -- Go back up tree to same level as current. while CURRENT_LEVEL < PREVIOUS_NODE.LEVEL loop PREVIOUS_NODE := PREVIOUS_NODE.PARENT; end loop; PREVIOUS_NODE.NEXT_TOPIC := HELP_UTILITY.CURRENT_NODE; HELP_UTILITY.CURRENT_NODE.PARENT := PREVIOUS_NODE; -- CASE 3: Level has not changed. else -- initial case only. Link off of TOP_NODE's subtopic link if PREVIOUS_NODE = HELP_UTILITY.TOP_NODE then PREVIOUS_NODE.SUBTOPICS := HELP_UTILITY.CURRENT_NODE; HELP_UTILITY.CURRENT_NODE.PARENT := PREVIOUS_NODE; -- all other cases when same level, link to next_topic. else PREVIOUS_NODE.NEXT_TOPIC := HELP_UTILITY.CURRENT_NODE; HELP_UTILITY.CURRENT_NODE.PARENT := PREVIOUS_NODE; end if; end if; -- Save the topics name, name length, and level HELP_UTILITY.CURRENT_NODE.NAME( 1..HELP_INFO_SUPPORT.FILE_TEXT_LINE'last) := LINE_BUFFER (FIRST_TEXT_CHAR .. LAST) & (LAST - FIRST_TEXT_CHAR + 2..HELP_INFO_SUPPORT.FILE_TEXT_LINE'last => ' '); HELP_UTILITY.CURRENT_NODE.NAME_LENGTH := LAST - FIRST_TEXT_CHAR + 1; HELP_UTILITY.CURRENT_NODE.LEVEL := CURRENT_LEVEL; -- update previous to current and go get next PREVIOUS_NODE := HELP_UTILITY.CURRENT_NODE; -- TEXT INPUT -- Add text to buffer elsif FIRST_DIGIT_FOUND then -- get a new blank line pointer CURRENT_LINE := new HELP_INFO_SUPPORT.TEXT_LINE; -- save the text CURRENT_LINE.TEXT_LINE := LINE_BUFFER(1..LAST) & (LAST+1 .. HELP_INFO_SUPPORT.FILE_TEXT_LINE'last => ' '); -- save the length if LAST = natural'first then CURRENT_LINE.LINE_LENGTH := LAST + 1; else CURRENT_LINE.LINE_LENGTH := LAST; end if; -- update pointers. First time, link to node, otherwise link to previous if PREVIOUS_LINE = null then HELP_UTILITY.CURRENT_NODE.TEXT_LINES := CURRENT_LINE; else PREVIOUS_LINE.NEXT_LINE := CURRENT_LINE; end if; -- update the previous line PREVIOUS_LINE := CURRENT_LINE; else raise TEXT_BEFORE_TOPIC; end if; -- reset flag. Loop back for next TOKEN_IS_DIGITS := false; -- reset flag end if; end loop; text_io.close (HELP_UTILITY.HELP_FILE_TYPE); -- set top node to a level of zero. This denotes the top HELP_UTILITY.TOP_NODE.LEVEL := 0; HELP_UTILITY.CURRENT_NODE := TOP_NODE; HELP_UTILITY.INITIALIZED := true; exception when TEXT_FILE_LEVEL_BAD | TEXT_BEFORE_TOPIC => raise HELP_UTILITY.ILLEGAL_FORMAT_FOR_HELP_FILE; when text_io.name_error => raise HELP_UTILITY.HELP_FILE_DOES_NOT_EXIST; when text_io.status_error | text_io.use_error => raise HELP_UTILITY.CANNOT_OPEN_HELP_FILE; when others => raise; end INITIALIZE; :::::::::: HELPME.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : HELP_ME -- Date created : 28 January 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : This is procedure is the driver of the Help utility. ----------------: It accepts the input from the CLI and determines the ----------------: appropriate action to take. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- separate (HELP_UTILITY) procedure HELP_ME(CLI_BUFFER: in string) is TOKEN_COUNT: positive := 1; -- number of tokens in input string MATCH_COUNT: natural := 0; -- number of token matches at current level COUNTER: natural := 0; -- loop control KEYWORD_MATCHES: HELP_UTILITY.HELP_LINK := null; -- list of nodes that match TOP_SAVE: HELP_UTILITY.HELP_LINK := null; -- first node of KEYWORD_MATCHES SAME_LEVEL: natural := 0; -- copy of current level of node MSG_NAME: HELP_INFO_SUPPORT.HELP_INFO_TEXT_LINE; BLANK_LINE_LENGTH: constant natural := 0; TEMP_NODE: HELP_UTILITY.HELP_LINK := new HELP_UTILITY.HELP_TOPIC; OUT_LINE_LENGTH: natural := 0; -- exceptions HELP_FILE_NOT_READ: exception; begin if not HELP_UTILITY.INITIALIZED then raise HELP_FILE_NOT_READ; end if; if HELP_UTILITY.HELP_MODE then -- parse the input string. A table of tokens is returned HELP_INFO_SUPPORT.PARSE(CLI_BUFFER); -- if no tokens, a carriage return was entered. move up a level if HELP_INFO_SUPPORT.NUMBER_OF_TOKENS = 0 then -- if this is the first time help is entered and no topic is specified, -- output the first level memu if HELP_UTILITY.FIRST_HELP_ME_CALL then HELP_UTILITY.OUTPUT_LINE := HELP_UTILITY.BLANK_LINE; HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.HEADER_LINE, HELP_UTILITY.HEADER_LINE'length); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_UTILITY.PRINT_TOPIC_MENU(CURRENT_NODE); -- else, if at the upper most level and a carriage return is entered, set -- terminate to true. else if HELP_UTILITY.CURRENT_NODE = HELP_UTILITY.TOP_NODE then HELP_UTILITY.EXIT_HELP; else -- not at top level. back up one level (until level changes) SAME_LEVEL := HELP_UTILITY.CURRENT_NODE.LEVEL; while HELP_UTILITY.CURRENT_NODE.LEVEL = SAME_LEVEL loop HELP_UTILITY.CURRENT_NODE := HELP_UTILITY.CURRENT_NODE.PARENT; end loop; end if; end if; else -- loop through the token table returned from PARSE until either: -- 1) "*" found, -- 2) "?" found, -- 3) more than one match is found at a level or -- 4) tokens are exhausted loop if HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).TOKEN(1.. HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).LENGTH) = "*" or HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).TOKEN(1.. HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).LENGTH) = "?" then exit; end if; FIND_KEYWORD(HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).TOKEN, HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).LENGTH, HELP_UTILITY.CURRENT_NODE, KEYWORD_MATCHES, MATCH_COUNT); -- if more than one (ambiguous input) or no match is found, then ignore the -- remaining tokens, exit loop if MATCH_COUNT /= 1 then exit; end if; -- if all tokens checked, exit loop if TOKEN_COUNT = HELP_INFO_SUPPORT.NUMBER_OF_TOKENS then exit; else -- increment the counter and update the current node to the match found TOKEN_COUNT := TOKEN_COUNT + 1; HELP_UTILITY.CURRENT_NODE := KEYWORD_MATCHES; end if; end loop; -- check if all info from current level on down is requested if HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).TOKEN(1.. HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).LENGTH) = "*" then if CURRENT_NODE = TOP_NODE then TEMP_NODE.all := HELP_UTILITY.CURRENT_NODE.SUBTOPICS.all; else TEMP_NODE.all := HELP_UTILITY.CURRENT_NODE.all; TEMP_NODE.NEXT_TOPIC := null; end if; HELP_UTILITY.DISPLAY_ALL_HELP_INFO(TEMP_NODE); if HELP_UTILITY.CURRENT_NODE.SUBTOPICS = null then SAME_LEVEL := HELP_UTILITY.CURRENT_NODE.LEVEL; while HELP_UTILITY.CURRENT_NODE.LEVEL = SAME_LEVEL loop HELP_UTILITY.CURRENT_NODE := HELP_UTILITY.CURRENT_NODE.PARENT ; end loop; end if; -- check if an implied help was requested, i.e., menu for current level elsif HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).TOKEN(1.. HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).LENGTH) = "?" then HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_UTILITY.PRINT_TOPIC_TEXT(HELP_UTILITY.CURRENT_NODE); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.ADD_HEADER_LINE, HELP_UTILITY.ADD_HEADER_LINE'length); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_UTILITY.PRINT_TOPIC_MENU(HELP_UTILITY.CURRENT_NODE); -- if a match(es) was found, output the info for that match(es) elsif MATCH_COUNT /= 0 then COUNTER := MATCH_COUNT; -- counter will be used for loop control TOP_SAVE := KEYWORD_MATCHES; -- save the top for later restoration -- this loop goes through the list (possibly only one) of matches found -- above. KEYWORD_MATCHES is a linked list of the matches. Each -- match has its text and menu of subtopics output while COUNTER /= 0 loop HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_UTILITY.OUTPUT_LINE := HELP_UTILITY.BLANK_LINE; HELP_UTILITY.OUTPUT_LINE(1..KEYWORD_MATCHES.NAME_LENGTH) := KEYWORD_MATCHES.NAME(1..KEYWORD_MATCHES.NAME_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.OUTPUT_LINE, KEYWORD_MATCHES.NAME_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_UTILITY.PRINT_TOPIC_TEXT(KEYWORD_MATCHES); -- check if any subtopics, i.e., if a menu should be output if KEYWORD_MATCHES.SUBTOPICS /= null then if TOKEN_COUNT < HELP_INFO_SUPPORT.NUMBER_OF_TOKENS then -- this checks for the case where an ambiguous token was entered followed -- by an "*". in this case, output all info for all the matches of the -- ambiguous input if HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT + 1).TOKEN(1.. HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT + 1).LENGTH) = "*" then HELP_UTILITY.DISPLAY_ALL_HELP_INFO(KEYWORD_MATCHES.SUBTOPICS); end if; else HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.ADD_HEADER_LINE, HELP_UTILITY.ADD_HEADER_LINE'length); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_UTILITY.PRINT_TOPIC_MENU(KEYWORD_MATCHES); end if; end if; KEYWORD_MATCHES := KEYWORD_MATCHES.NEXT_TOPIC; COUNTER := COUNTER - 1; end loop; -- restore the top of the list KEYWORD_MATCHES := TOP_SAVE; -- now we must decide what the next prompt should be (and thus, what the -- current node should be [or vice versa]). -- this only matters if one and only one match was found. Else, the -- current node did not change. if MATCH_COUNT = 1 then -- if there are no subtopics, the prompt should be for the next higher -- level. if KEYWORD_MATCHES.SUBTOPICS = null then -- if already at the highest level, set current to top if KEYWORD_MATCHES.LEVEL <= 1 then HELP_UTILITY.CURRENT_NODE := HELP_UTILITY.TOP_NODE; else -- else, move up the links until the level changes. That node will then -- become the current level SAME_LEVEL := KEYWORD_MATCHES.LEVEL; while KEYWORD_MATCHES.LEVEL = SAME_LEVEL loop KEYWORD_MATCHES := KEYWORD_MATCHES.PARENT; end loop; HELP_UTILITY.CURRENT_NODE := KEYWORD_MATCHES; end if; else -- if there are subtopics, the current node becomes the one found and -- the user is prompted for subtopic input HELP_UTILITY.CURRENT_NODE := KEYWORD_MATCHES; end if; end if; else -- if no match was found and not a special character (* or ?) then no info -- for user input request HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); if HELP_UTILITY.NO_DOC_LINE'length + HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).LENGTH >= HELP_INFO_SUPPORT.MAX_LINE_LENGTH then MSG_NAME(1..HELP_INFO_SUPPORT.MAX_LINE_LENGTH) := HELP_UTILITY.NO_DOC_LINE & HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).TOKEN(1.. HELP_INFO_SUPPORT.MAX_LINE_LENGTH - HELP_UTILITY.NO_DOC_LINE'length); OUT_LINE_LENGTH := HELP_INFO_SUPPORT.MAX_LINE_LENGTH; else MSG_NAME(1..HELP_INFO_SUPPORT.MAX_LINE_LENGTH) := HELP_UTILITY.NO_DOC_LINE & HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).TOKEN(1.. HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).LENGTH) & (HELP_UTILITY.NO_DOC_LINE'length + HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).LENGTH + 1 .. HELP_INFO_SUPPORT.HELP_INFO_TEXT_LINE'last => ' '); OUT_LINE_LENGTH := HELP_UTILITY.NO_DOC_LINE'length + HELP_INFO_SUPPORT.INPUT_TOKEN_TABLE(TOKEN_COUNT).LENGTH; end if; HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(MSG_NAME, OUT_LINE_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.ADD_HEADER_LINE, HELP_UTILITY.ADD_HEADER_LINE'length); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); if HELP_UTILITY.CURRENT_NODE.LEVEL >= 1 then if TOKEN_COUNT > 1 and HELP_UTILITY.CURRENT_NODE.LEVEL /= HELP_UTILITY.CURRENT_NODE.PARENT.LEVEL then HELP_UTILITY.CURRENT_NODE := HELP_UTILITY.CURRENT_NODE.PARENT; end if; end if; HELP_UTILITY.PRINT_TOPIC_MENU(HELP_UTILITY.CURRENT_NODE); TOKEN_COUNT := HELP_INFO_SUPPORT.NUMBER_OF_TOKENS; end if; end if; -- before outputting the prompt, check that help was not terminated if HELP_UTILITY.HELP_MODE then HELP_UTILITY.PRINT_CURRENT_PROMPT(HELP_UTILITY.CURRENT_NODE); end if; -- indicate that HELP is active HELP_UTILITY.FIRST_HELP_ME_CALL := false; end if; exception when HELP_FILE_NOT_READ => raise HELP_UTILITY.HELP_FILE_NOT_INITIALIZED; when others => HELP_UTILITY.HELP_MODE := false; raise; end HELP_ME; :::::::::: HELPMENU.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : PRINT_TOPIC_MENU -- Date created : 28 January 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : This procedure will print a list of subtopics (menu) for ----------------: the given node (if any exist). The subtopics are listed ----------------: in two columns. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- separate (HELP_UTILITY) procedure PRINT_TOPIC_MENU (NODE: in HELP_UTILITY.HELP_LINK) is TOTAL_NUMBER_OF_TOPICS: natural := 0; NUM_TOPICS_IN_COLUMN_ONE: positive := 1; TOPICS_IN_COLUMN_TWO: boolean := false; COL_WIDTH: integer := (HELP_INFO_SUPPORT.MAX_LINE_LENGTH/2) - 1; RIGHT_COLUMN_START: integer := COL_WIDTH + 3; EVEN: boolean := false; CURRENT_NODE: HELP_UTILITY.HELP_LINK := null; COL_ONE_NODE: HELP_UTILITY.HELP_LINK := null; COL_TWO_NODE: HELP_UTILITY.HELP_LINK := null; begin CURRENT_NODE := NODE.SUBTOPICS; -- count the number of subtopics for this node while CURRENT_NODE /= null loop TOTAL_NUMBER_OF_TOPICS := TOTAL_NUMBER_OF_TOPICS + 1; CURRENT_NODE:= CURRENT_NODE.NEXT_TOPIC; end loop; -- If there is more than one topic, then split the topics into two columns -- Column one will have the first half and column two the second half. -- If there are an odd number of topics, column one will have the odd number if TOTAL_NUMBER_OF_TOPICS /= 0 then if TOTAL_NUMBER_OF_TOPICS >= 2 then TOPICS_IN_COLUMN_TWO := true; NUM_TOPICS_IN_COLUMN_ONE := TOTAL_NUMBER_OF_TOPICS / 2; -- More than one topic, split the number -- See if odd number. If so, increment the topic count so odd goes in 1st col. if TOTAL_NUMBER_OF_TOPICS /= (TOTAL_NUMBER_OF_TOPICS/2) * 2 then NUM_TOPICS_IN_COLUMN_ONE := NUM_TOPICS_IN_COLUMN_ONE + 1; else EVEN := true; end if; end if; -- set the beginning node for each column COL_ONE_NODE := NODE.SUBTOPICS; CURRENT_NODE := NODE.SUBTOPICS; for I in 1..NUM_TOPICS_IN_COLUMN_ONE loop COL_TWO_NODE := CURRENT_NODE.NEXT_TOPIC; CURRENT_NODE := CURRENT_NODE.NEXT_TOPIC; end loop; if TOPICS_IN_COLUMN_TWO then while COL_TWO_NODE /= null loop HELP_UTILITY.OUTPUT_LINE := HELP_UTILITY.BLANK_LINE; -- blank the line buffer -- Put first topic in left half of output line -- if full name will not fit then truncate if COL_WIDTH > COL_ONE_NODE.NAME_LENGTH then -- full name will fit HELP_UTILITY.OUTPUT_LINE(1..COL_ONE_NODE.NAME_LENGTH) := COL_ONE_NODE.NAME(1..COL_ONE_NODE.NAME_LENGTH); else -- truncate HELP_UTILITY.OUTPUT_LINE(1..COL_WIDTH) := COL_ONE_NODE.NAME(1..COL_WIDTH); end if; -- Put second topic in second half of output line -- if full name will not fit then truncate if COL_WIDTH > COL_TWO_NODE.NAME_LENGTH then -- full name will fit HELP_UTILITY.OUTPUT_LINE(RIGHT_COLUMN_START..RIGHT_COLUMN_START + COL_TWO_NODE.NAME_LENGTH - 1 ) := COL_TWO_NODE.NAME(1..COL_TWO_NODE.NAME_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.OUTPUT_LINE, RIGHT_COLUMN_START - 1 + COL_TWO_NODE.NAME_LENGTH); else -- truncate HELP_UTILITY.OUTPUT_LINE(RIGHT_COLUMN_START..RIGHT_COLUMN_START + COL_WIDTH - 1) := COL_TWO_NODE.NAME(1..COL_WIDTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.OUTPUT_LINE, RIGHT_COLUMN_START - 1 + COL_WIDTH); end if; COL_ONE_NODE := COL_ONE_NODE.NEXT_TOPIC; COL_TWO_NODE := COL_TWO_NODE.NEXT_TOPIC; end loop; end if; if not EVEN then -- Put the odd topic in the output buffer HELP_UTILITY.OUTPUT_LINE := HELP_UTILITY.BLANK_LINE; -- check if name will fit on output line if HELP_INFO_SUPPORT.MAX_LINE_LENGTH > COL_ONE_NODE.NAME_LENGTH then -- name fits HELP_UTILITY.OUTPUT_LINE(1..COL_ONE_NODE.NAME_LENGTH) := COL_ONE_NODE.NAME(1..COL_ONE_NODE.NAME_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.OUTPUT_LINE, COL_ONE_NODE.NAME_LENGTH); -- truncate else HELP_UTILITY.OUTPUT_LINE(1..HELP_INFO_SUPPORT.MAX_LINE_LENGTH) := COL_ONE_NODE.NAME(1..HELP_INFO_SUPPORT.MAX_LINE_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.OUTPUT_LINE, HELP_INFO_SUPPORT.MAX_LINE_LENGTH); end if; end if; end if; exception when others => raise; end PRINT_TOPIC_MENU; :::::::::: HELPPROMP.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : PRINT_CURRENT_PROMPT -- Date created : 28 January 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : This procedure determines the prompt and outputs it. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- separate(HELP_UTILITY) procedure PRINT_CURRENT_PROMPT(NODE: in HELP_UTILITY.HELP_LINK) is TEMP_NODE: HELP_UTILITY.HELP_LINK := null; PROMPT_END: integer := 1; -- number of allowable characters for prompt SAVE_CURRENT_LEVEL: integer := 0; -- used in reverse tree traversal PROMPT_NAME: HELP_INFO_SUPPORT.HELP_INFO_TEXT_LINE := HELP_UTILITY.BLANK_LINE; BLANK_LINE_LENGTH: constant natural := 0; begin -- there are two types of prompts: -- 1) "topic? " -- 2) "subtopic? " -- "topic? " is output when at the highest level (at the top node) if NODE = HELP_UTILITY.TOP_NODE then HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.TOPIC_LINE, HELP_UTILITY.TOPIC_LINE'length); else -- when at a lower level output the topic name(s) followed by "subtopic? " TEMP_NODE := NODE; SAVE_CURRENT_LEVEL := NODE.LEVEL; -- put the prompt "subtopic? " in the buffer PROMPT_NAME(1..HELP_UTILITY.SUBTOPIC_LINE'length) := HELP_UTILITY.SUBTOPIC_LINE; PROMPT_END := HELP_INFO_SUPPORT.MAX_LINE_LENGTH - HELP_UTILITY.SUBTOPIC_LINE'length - 1; -- now put the name of the current node in the buffer before the prompt PROMPT_NAME(1..TEMP_NODE.NAME_LENGTH + HELP_INFO_SUPPORT.MAX_LINE_LENGTH - PROMPT_END + 1) := TEMP_NODE.NAME(1..TEMP_NODE.NAME_LENGTH) & ' ' & PROMPT_NAME(1..HELP_INFO_SUPPORT.MAX_LINE_LENGTH - PROMPT_END); PROMPT_END := PROMPT_END - TEMP_NODE.NAME_LENGTH - 1; -- do a reverse tree traversal starting at the current node. if a level -- changes, put that node's name in the output string while TEMP_NODE.LEVEL > 0 loop if SAVE_CURRENT_LEVEL /= TEMP_NODE.LEVEL then SAVE_CURRENT_LEVEL := TEMP_NODE.LEVEL; if SAVE_CURRENT_LEVEL > 0 then -- if the name will not fit then exit and go with what we have if TEMP_NODE.NAME_LENGTH + 1 > PROMPT_END then exit; end if; PROMPT_NAME(1..TEMP_NODE.NAME_LENGTH + HELP_INFO_SUPPORT.MAX_LINE_LENGTH - PROMPT_END + 1) := TEMP_NODE.NAME(1..TEMP_NODE.NAME_LENGTH) & ' ' & PROMPT_NAME(1..HELP_INFO_SUPPORT.MAX_LINE_LENGTH - PROMPT_END); PROMPT_END := PROMPT_END - TEMP_NODE.NAME_LENGTH - 1; end if; end if; TEMP_NODE := TEMP_NODE.PARENT; end loop; HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(HELP_UTILITY.BLANK_LINE, BLANK_LINE_LENGTH); HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(PROMPT_NAME, HELP_INFO_SUPPORT.MAX_LINE_LENGTH - PROMPT_END - 1); end if; exception when others => raise; end PRINT_CURRENT_PROMPT; :::::::::: HELPRESET.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : RESET_HELP -- Date created : 04 March 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : The procedure sets the help mode flag to true and ----------------: resets the current node pointer to the top node of the ----------------: tree. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- separate (HELP_UTILITY) procedure RESET_HELP is begin HELP_UTILITY.CURRENT_NODE := HELP_UTILITY.TOP_NODE; -- set HELP_MODE to on HELP_UTILITY.HELP_MODE := true; HELP_UTILITY.FIRST_HELP_ME_CALL := true; end RESET_HELP; :::::::::: HELPTEXT.ADA :::::::::: -------------------------PROLOGUE--------------------------------------- -- -* -- Unit name : PRINT_TOPIC_TEXT -- Date created : 28 January 1985 -- Last update : -- -* ------------------------------------------------------------------------ -- -* -- Abstract : This procedure prints the text assoicated with the ----------------: given node. -- -* ------------------------------------------------------------------------ -- -- Mnemonic : -- Name : -- Release date : ------------------ Revision history ------------------------------------ -- -- DATE AUTHOR HISTORY -- -- -- --------------------END-PROLOGUE---------------------------------------- separate (HELP_UTILITY) procedure PRINT_TOPIC_TEXT (NODE: in HELP_UTILITY.HELP_LINK) is CURRENT_LINE: HELP_INFO_SUPPORT.TEXT_LINK; begin CURRENT_LINE := NODE.TEXT_LINES; while CURRENT_LINE /= null loop HELP_INFO_SUPPORT.APPEND_TO_DISPLAY(CURRENT_LINE.TEXT_LINE, CURRENT_LINE.LINE_LENGTH); CURRENT_LINE := CURRENT_LINE.NEXT_LINE; end loop; exception when others => raise; end PRINT_TOPIC_TEXT; :::::::::: HELPFILEB.ADA :::::::::: with TEXT_IO; with HELP_UTILITY; package body HELP is procedure HELP_SCREEN (LEVEL: LEVEL_TYPE; HELP_FILE_NAME : string) is -------------------------------------------------------------------------- -- Abstract : This routine provides a help_screen, based on the two -- parameters. -------------------------------------------------------------------------- -- Parameters : LEVEL - Level of help requested -- HELP_FILE_NAME - Name of help file -------------------------------------------------------------------------- -- Constants and variables HELP_TOPIC : string (1..80); TOPIC_LENGTH : natural; FIRST_CALL: BOOLEAN := TRUE; procedure OUTPUT_HELP_INFO is HELP_INFO : string (1..80); HELP_INFO_LENGTH: natural; IS_LAST : BOOLEAN; begin TEXT_IO.NEW_LINE; HELP_UTILITY.GET_TEXT_LINE(HELP_INFO,HELP_INFO_LENGTH,IS_LAST); while not IS_LAST loop TEXT_IO.PUT_LINE(HELP_INFO); TEXT_IO.NEW_LINE; HELP_INFO_LENGTH := HELP_INFO'LENGTH; HELP_UTILITY.GET_TEXT_LINE(HELP_INFO,HELP_INFO_LENGTH,IS_LAST); end loop; TEXT_IO.PUT(HELP_INFO(1..HELP_INFO_LENGTH)); end OUTPUT_HELP_INFO; begin -- begin main procedure -- -- Initialize HELP_FILE the first time through -- if FIRST_CALL then HELP_UTILITY.INITIALIZE(HELP_FILE_NAME); FIRST_CALL := FALSE; end if; -- -- Clear screen -- TEXT_IO.NEW_PAGE; -- -- Make initial call to HELP entering at level call was made HELP_UTILITY.HELP_ME(LEVEL); -- -- Handle other help requests at this level -- while not HELP_UTILITY.HELP_IS_TERMINATED loop OUTPUT_HELP_INFO; TEXT_IO.GET_LINE(HELP_TOPIC,TOPIC_LENGTH); HELP_UTILITY.HELP_ME(HELP_TOPIC(1..TOPIC_LENGTH)); end loop; TEXT_IO.NEW_LINE; HELP_UTILITY.RESET_HELP; -- Make sure you reset HELP for future -- entries into Help_screen exception when HELP_UTILITY.HELP_FILE_DOES_NOT_EXIST => raise HELP_FILE_ERROR; when HELP_UTILITY.CANNOT_OPEN_HELP_FILE => raise HELP_OPEN_ERROR; when HELP_UTILITY.ILLEGAL_FORMAT_FOR_HELP_FILE => raise HELP_FORMAT_ERROR; end HELP_SCREEN; end HELP; :::::::::: filebody.ada :::::::::: with COMMAND_LINE_HANDLER; with CURRENT_EXCEPTION; with TEXT_IO; package body FILE_HANDLING is MAX_FILE_NAME_LENGTH : constant NATURAL := 128; subtype FILE_NAME_STRING is STRING (1 .. MAX_FILE_NAME_LENGTH); FILE_STACK_SIZE : constant NATURAL := 20; FILE_STACK : array (1 .. FILE_STACK_SIZE) of TEXT_IO.FILE_TYPE; FILE_STACK_POINTER : NATURAL := 0; NESTED_FILE_INDICATOR : constant CHARACTER := '@'; EXTENSION_CHAR : constant CHARACTER := '.'; HELP_CHAR : constant CHARACTER := '?'; FILE_NAME : FILE_NAME_STRING; FILE_NAME_LENGTH : NATURAL; FLAW_FILE_NAME : FILE_NAME_STRING; FLAW_FILE_NAME_LENGTH : NATURAL; FLAW_TYPE : constant STRING (1 .. 3) := "FLW"; STYLE_FILE_NAME : FILE_NAME_STRING; STYLE_FILE_NAME_LENGTH : NATURAL; STYLE_TYPE : constant STRING (1 .. 3) := "STY"; IS_FILE_NAME_DEFINED : BOOLEAN := FALSE; COMMAND_LINE_FILE_NAME : constant STRING := "COMMAND_LINE.TXT"; NO_MORE_FILES : exception; INCLUDE_STACK_OVERFLOW : exception; INPUT_FILE_MISSING : exception; FILE_NAME_ILLEGAL : exception; -- -- Close the current file on the top of the file stack and pop down -- to the next element on the file stack (viz, the file opened before -- the file that was just closed). POP the old file from the top of -- the file stack. -- procedure POP is begin TEXT_IO.CLOSE (FILE_STACK (FILE_STACK_POINTER)); FILE_STACK_POINTER := FILE_STACK_POINTER - 1; end POP; -- -- If file stack is not full, increment file stack pointer and open -- the file whose name is in FILE_NAME (2..FILE_NAME_LENGTH) as the -- new current file on the file stack. PUSH a new file onto the file -- stack. -- procedure PUSH is begin if FILE_STACK_POINTER = FILE_STACK_SIZE then raise INCLUDE_STACK_OVERFLOW; end if; FILE_STACK_POINTER := FILE_STACK_POINTER + 1; TEXT_IO.OPEN (FILE_STACK (FILE_STACK_POINTER), TEXT_IO.IN_FILE, FILE_NAME (2 .. FILE_NAME_LENGTH)); exception when INCLUDE_STACK_OVERFLOW => raise; when others => raise INPUT_FILE_MISSING; end PUSH; -- -- Return the next file name in FILE_NAME and FILE_NAME_LENGTH from -- the command line and all included files. -- procedure RETURN_NEXT_FILE_NAME is INDEX : NATURAL; RETRY : BOOLEAN; begin -- -- Loop until we encounter a file name which is NOT an include file -- loop -- -- Loop until we encounter a file name -- loop RETRY := TRUE; if FILE_STACK_POINTER = 0 then begin COMMAND_LINE_HANDLER.NEXT_WORD (COMMAND_LINE_FILE_NAME, FILE_NAME, FILE_NAME_LENGTH); RETRY := FALSE; exception when others => raise NO_MORE_FILES; end; else begin TEXT_IO.GET_LINE (FILE_STACK (FILE_STACK_POINTER), FILE_NAME, FILE_NAME_LENGTH); RETRY := FALSE; exception when others => POP; RETRY := TRUE; end; end if; exit when not RETRY; end loop; if FILE_NAME (1) = NESTED_FILE_INDICATOR then PUSH; RETRY := TRUE; end if; exit when not RETRY; end loop; -- -- If this is the first file name provided, name the Flaw and Style -- files after it -- if not IS_FILE_NAME_DEFINED then if FILE_NAME(1) = HELP_CHAR then raise HELP_ASKED_FOR; else INDEX := FILE_NAME_LENGTH + 1; for I in 1 .. FILE_NAME_LENGTH loop -- search for the LAST EXTENSION character ('.') -- Note on Data General there can be several '.' -- in a file name! if FILE_NAME(I) = EXTENSION_CHAR then INDEX := I; end if; end loop; FLAW_FILE_NAME (1 .. INDEX+FLAW_TYPE'LAST) := FILE_NAME(1..INDEX-1) & EXTENSION_CHAR & FLAW_TYPE; STYLE_FILE_NAME (1 .. INDEX + STYLE_TYPE'LAST) := FILE_NAME(1..INDEX-1) & EXTENSION_CHAR & STYLE_TYPE; FLAW_FILE_NAME_LENGTH := INDEX + FLAW_TYPE'LAST; STYLE_FILE_NAME_LENGTH := INDEX + FLAW_TYPE'LAST; IS_FILE_NAME_DEFINED := TRUE; end if; end if; exception when NO_MORE_FILES => raise; when HELP_ASKED_FOR => raise; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in RETURN_NEXT_FILE_NAME."); raise; end RETURN_NEXT_FILE_NAME; -- -- Obtain the next file name and open it -- procedure INPUT_FILE_ID (FILE_ID : in out TEXT_IO.FILE_TYPE; MORE_FILES : out BOOLEAN) is OPEN_SUCCESSFUL : BOOLEAN; CANNOT_OPEN_MSG : constant STRING := "This file cannot be opened! : "; STACK_OFLOW_MSG : constant STRING := "The File-list stack overflowed. Attempting to continue!?"; begin loop begin OPEN_SUCCESSFUL := true; RETURN_NEXT_FILE_NAME; if TEXT_IO.IS_OPEN( FILE_ID ) then TEXT_IO.CLOSE( FILE_ID ); end if; TEXT_IO.OPEN (FILE_ID, TEXT_IO.IN_FILE, FILE_NAME (1 .. FILE_NAME_LENGTH)); MORE_FILES := TRUE; exception when TEXT_IO.NAME_ERROR | TEXT_IO.USE_ERROR => TEXT_IO.PUT_LINE(CANNOT_OPEN_MSG & FILE_NAME(1 .. FILE_NAME_LENGTH) ); OPEN_SUCCESSFUL := false; when INCLUDE_STACK_OVERFLOW => TEXT_IO.PUT_LINE(STACK_OFLOW_MSG); OPEN_SUCCESSFUL := false; when OTHERS => raise; end; exit when OPEN_SUCCESSFUL; end loop; exception when TEXT_IO.NAME_ERROR | TEXT_IO.USE_ERROR => TEXT_IO.PUT_LINE( CANNOT_OPEN_MSG ); raise; when HELP_ASKED_FOR => raise; when NO_MORE_FILES => MORE_FILES := FALSE; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in RETURN_NEXT_FILE_NAME."); raise FILE_NAME_ILLEGAL; end INPUT_FILE_ID; -- -- Create the Flaw and Style files and return their IDs -- procedure OUTPUT_FILE_ID (FLAWS_FILE_ID : in out TEXT_IO.FILE_TYPE; STYLE_FILE_ID : in out TEXT_IO.FILE_TYPE) is CANNOT_OPEN_MSG : constant STRING := "Cannot OPEN output files! This program will fail uncleanly!"; begin TEXT_IO.CREATE (FLAWS_FILE_ID, TEXT_IO.OUT_FILE, FLAW_FILE_NAME (1 .. FLAW_FILE_NAME_LENGTH)); TEXT_IO.CREATE (STYLE_FILE_ID, TEXT_IO.OUT_FILE, STYLE_FILE_NAME (1 .. STYLE_FILE_NAME_LENGTH)); exception when TEXT_IO.NAME_ERROR | TEXT_IO.USE_ERROR => TEXT_IO.PUT_LINE( CANNOT_OPEN_MSG ); raise; when OTHERS => raise; end OUTPUT_FILE_ID; end FILE_HANDLING; :::::::::: tokenzbod.ada :::::::::: with FILE_HANDLING; with CURRENT_EXCEPTION; with DYN; use DYN; -- must use use to overload -- operators package body TOKENIZER is -------------------------------------------------------------------------- -- Abstract : This is the body to the Tokenizer package. This body -- contains all the routines to build the token chain from -- the input Ada source. -------------------------------------------------------------------------- -- types used for input files subtype LINE_STRING is STRING(1..LINE_INDEX_RANGE'LAST); -- an input line record subtype LINE_COLUMN is INTEGER range -1..LINE_INDEX_RANGE'LAST; type LINE_RECORD is -- Buffer containing current record -- Line of file LINE : LINE_STRING; -- Line of text COLUMN : LINE_COLUMN := 0; -- Current column LENGTH : LINE_COLUMN := 0; -- Length of current line end record; -- "global" variables CURRENT_LINE_NUMBER : LINE_NUM_RANGE := 0; CURRENT_LINE : LINE_RECORD; ID : DYN.DYN_STRING; -- Current identifier ROOT : IDENTIFIER_TREE := null; -- Root of binary tree ROOT_TOKEN : TOKEN_POINTER; -- First token INPUT_FILE : TEXT_IO.FILE_TYPE; END_LINE : exception; END_FILE : exception; -- Internal procedures and functions procedure INSERT -- Insert identifier into tree (STRG : in DYN.DYN_STRING; -- String to be inserted T : in out IDENTIFIER_TREE); -- Tree to add it to function IS_A_RESERVED_WORD -- determines if Id is a -- reserved word (ID : in DYN.DYN_STRING) -- String to check return BOOLEAN; function RESERVED_WORD (ID : in DYN.DYN_STRING) return KEYWORDS; function NEXT_CHARACTER return CHARACTER; -- Gets next character from -- input file function NEXT_IDENTIFIER return TOKEN; -- Gets next token from input procedure INSERT(STRG : in DYN.DYN_STRING; T : in out IDENTIFIER_TREE) is separate; function IS_A_RESERVED_WORD(ID : in DYN.DYN_STRING) return BOOLEAN is separate; function RESERVED_WORD (ID : in DYN.DYN_STRING) return KEYWORDS is separate; function NEXT_CHARACTER return CHARACTER is separate; function NEXT_IDENTIFIER return TOKEN is separate; function TREE_ROOT return IDENTIFIER_TREE is separate; function EXTERNAL_REPRESENTATION(CURRENT_TOKEN : in TOKEN) return DYN.DYN_STRING is -------------------------------------------------------------------------- -- Abstract : This function returns the exact physical represeantation -- in the input source for the token. -------------------------------------------------------------------------- -- Parameters : CURRENT_TOKEN - Token to give representation for -------------------------------------------------------------------------- ANSWER : DYN.DYN_STRING; begin case CURRENT_TOKEN.TYPE_OF_TOKEN is -- Check for tokens that have a constant representation -- ( operators , etc.) when END_OF_LINE => ANSWER := D_STRING(""); when CONCATENATION_OPERATOR => ANSWER := D_STRING("&"); when TICK => ANSWER := D_STRING("'"); when RIGHT_PARENTHESIS => ANSWER := D_STRING(")"); when LEFT_PARENTHESIS => ANSWER := D_STRING("("); when MULTIPLICATION_OPERATOR => ANSWER := D_STRING("*"); when ADDITION_OPERATOR => ANSWER := D_STRING("+"); when COMMA => ANSWER := D_STRING(","); when SUBTRACTION_OPERATOR => ANSWER := D_STRING("-"); when PERIOD => ANSWER := D_STRING("."); when DIVISION_OPERATOR => ANSWER := D_STRING("/"); when COLON => ANSWER := D_STRING(":"); when SEMICOLON => ANSWER := D_STRING(";"); when LESS_THAN_OPERATOR => ANSWER := D_STRING("<"); when EQUAL_OPERATOR => ANSWER := D_STRING("="); when GREATER_THAN_OPERATOR => ANSWER := D_STRING(">"); when VERTICAL_BAR => ANSWER := D_STRING("|"); when COMMENT => ANSWER := D_STRING("--") & CURRENT_TOKEN.PHYSICAL_REPRESENTATION; when ARROW => ANSWER := D_STRING("=>"); when DOUBLE_DOT => ANSWER := D_STRING(".."); when EXPONENTIATE_OPERATOR => ANSWER := D_STRING("**"); when ASSIGNMENT_OPERATOR => ANSWER := D_STRING(":="); when INEQUAL_OPERATOR => ANSWER := D_STRING("/="); when GREATER_THAN_OR_EQUAL_OPERATOR => ANSWER := D_STRING(">="); when LESS_THAN_OR_EQUAL_OPERATOR => ANSWER := D_STRING("<="); when LEFT_LABEL_BRACKET => ANSWER := D_STRING("<<"); when RIGHT_LABEL_BRACKET => ANSWER := D_STRING(">>"); when BOX => ANSWER := D_STRING("<>"); when STRING_LITERAL => ANSWER := D_STRING('"') & CURRENT_TOKEN.PHYSICAL_REPRESENTATION & D_STRING('"'); when CHARACTER_LITERAL => ANSWER := D_STRING("'") & CURRENT_TOKEN.PHYSICAL_REPRESENTATION & D_STRING("'"); when others => ANSWER := CURRENT_TOKEN.PHYSICAL_REPRESENTATION; end case; return ANSWER; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in EXTERNAL_REPRESENTATION"); raise; end EXTERNAL_REPRESENTATION; function FIRST_TOKEN return TOKEN is -------------------------------------------------------------------------- -- Abstract : This function returns the first token in the input file. -- The first token is used as a starting point by the -- Style_Checker. -------------------------------------------------------------------------- begin return ROOT_TOKEN.all; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in FIRST_TOKEN"); raise; end FIRST_TOKEN; function LENGTH_OF_COMMENT(CURRENT_TOKEN : in TOKEN) return NATURAL is -------------------------------------------------------------------------- -- Abstract : This routine returns the length of a comment token -------------------------------------------------------------------------- -- Parameters : CURRENT_TOKEN - Comment token -------------------------------------------------------------------------- begin if TYPE_OF_TOKEN_IS(CURRENT_TOKEN) = COMMENT then return LENGTH(CURRENT_TOKEN.PHYSICAL_REPRESENTATION); else raise INVALID_TOKEN; end if; exception when INVALID_TOKEN => raise; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in LENGTH_OF_COMMENT"); raise; end LENGTH_OF_COMMENT; function NEXT_TOKEN(CURRENT_TOKEN : in TOKEN) return TOKEN is -------------------------------------------------------------------------- -- Abstract : This function returns the token in the input stream that -- follows the token input to this routine. -------------------------------------------------------------------------- -- Parameters : CURRENT_TOKEN - Return token that follows this token -------------------------------------------------------------------------- begin if CURRENT_TOKEN.NEXT_TOKEN /= null then return CURRENT_TOKEN.NEXT_TOKEN.all; else raise END_OF_TOKENS; end if; exception when END_OF_TOKENS => raise; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in NEXT_TOKEN"); raise; end NEXT_TOKEN; function PREVIOUS_TOKEN(CURRENT_TOKEN : in TOKEN) return TOKEN is -------------------------------------------------------------------------- -- Abstract : This function returns the token in the input stream that -- precedes the token input to this routine. -------------------------------------------------------------------------- -- Parameters : CURRENT_TOKEN - Return token that precedes this token -------------------------------------------------------------------------- begin if CURRENT_TOKEN.PREVIOUS_TOKEN /= null then return CURRENT_TOKEN.PREVIOUS_TOKEN.all; else raise END_OF_TOKENS; end if; exception when END_OF_TOKENS => raise; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in PREVIOUS_TOKEN"); raise; end PREVIOUS_TOKEN; function TYPE_OF_TOKEN_IS(CURRENT_TOKEN : in TOKEN) return TOKEN_TYPE is -------------------------------------------------------------------------- -- Abstract : This function returns the type associated with the input -- token. -------------------------------------------------------------------------- -- Parameters : CURRENT_TOKEN - Token to return type of. -------------------------------------------------------------------------- begin return CURRENT_TOKEN.TYPE_OF_TOKEN; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in TYPE_OF_TOKEN_IS"); raise; end TYPE_OF_TOKEN_IS; procedure BUILD_TOKENS is separate; procedure TOKEN_POSITION(CURRENT_TOKEN : in TOKEN; LINE : out LINE_NUM_RANGE; COLUMN : out LINE_INDEX_RANGE) is -------------------------------------------------------------------------- -- Abstract : This routine returns the line and column position of the -- input token. -------------------------------------------------------------------------- -- Parameters : CURRENT_TOKEN - Input token -- LINE - Line number associated with input token -- COLUMN - Column number associated with input token -------------------------------------------------------------------------- begin LINE := CURRENT_TOKEN.TOKEN_POSITION.LINE; COLUMN := CURRENT_TOKEN.TOKEN_POSITION.COLUMN; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in TOKEN_POSITION"); raise; end TOKEN_Position; procedure LINE_CONTAINING_TOKEN(CURRENT_TOKEN : in TOKEN; LINE : out DYN.DYN_STRING) is separate; end TOKENIZER; :::::::::: insert.ada :::::::::: separate (TOKENIZER) procedure INSERT -- Insert identifier into tree (STRG : in DYN.DYN_STRING; -- String to be inserted T : in out IDENTIFIER_TREE) is -- Tree to add it to -------------------------------------------------------------------------- -- Abstract : This routine inserts an identifier into the binary tree -- of identifiers exported by the Tokenizer package. -------------------------------------------------------------------------- -- Parameters : STRG - Identifier to add to tree (if not already in it) -- T - Root of tree to add it to. -------------------------------------------------------------------------- -- Algorithm : Typical binary tree insertion. -- If T is null then insert identifier at T -- Else -- If T is the identifier add new reference -- Else -- Recursively call this routine with -- Left or Right pointer -------------------------------------------------------------------------- FOLLOW_CHAIN : REFPTR; begin if T = null then -- add to tree here T := new IDENTIFIER_NODE; T.LEFT := null; T.RIGHT := null; T.REFERENCES := new REFS; T.REFERENCES.STRG := STRG; T.REFERENCES.NEXT := null; else if UPPER_CASE(T.REFERENCES.STRG) = -- new reference to identifier UPPER_CASE(STRG) then FOLLOW_CHAIN := T.REFERENCES; while FOLLOW_CHAIN.NEXT /= null loop FOLLOW_CHAIN := FOLLOW_CHAIN.NEXT; end loop; FOLLOW_CHAIN.NEXT := new REFS; FOLLOW_CHAIN.NEXT.NEXT := null; FOLLOW_CHAIN.NEXT.STRG := STRG; else if UPPER_CASE(T.REFERENCES.STRG) > UPPER_CASE(STRG) then INSERT(STRG,T.LEFT); else INSERT(STRG,T.RIGHT); end if; end if; end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("in INSERT"); raise; end INSERT; :::::::::: isareserv.ada :::::::::: separate (TOKENIZER) function IS_A_RESERVED_WORD -- determines if Id is a -- reserved word (ID : in DYN.DYN_STRING) return BOOLEAN is -- String to check -------------------------------------------------------------------------- -- Abstract : This function returns true if the input name is an Ada -- reserved word, otherwise it returns false. -------------------------------------------------------------------------- -- Parameters : ID - Name to check -------------------------------------------------------------------------- ANSWER : BOOLEAN; -- this is the return begin case DYN.LENGTH(ID) is when 2 => ANSWER := UPPER_CASE(ID) = "AT" or UPPER_CASE(ID) = "DO" or UPPER_CASE(ID) = "IF" or UPPER_CASE(ID) = "IN" or UPPER_CASE(ID) = "IS" or UPPER_CASE(ID) = "OF" or UPPER_CASE(ID) = "OR"; when 3 => ANSWER := UPPER_CASE(ID) = "ABS" or UPPER_CASE(ID) = "ALL" or UPPER_CASE(ID) = "AND" or UPPER_CASE(ID) = "END" or UPPER_CASE(ID) = "FOR" or UPPER_CASE(ID) = "MOD" or UPPER_CASE(ID) = "NEW" or UPPER_CASE(ID) = "NOT" or UPPER_CASE(ID) = "OUT" or UPPER_CASE(ID) = "REM" or UPPER_CASE(ID) = "USE" or UPPER_CASE(ID) = "XOR"; when 4 => ANSWER := UPPER_CASE(ID) = "BODY" or UPPER_CASE(ID) = "CASE" or UPPER_CASE(ID) = "ELSE" or UPPER_CASE(ID) = "EXIT" or UPPER_CASE(ID) = "GOTO" or UPPER_CASE(ID) = "LOOP" or UPPER_CASE(ID) = "NULL" or UPPER_CASE(ID) = "TASK" or UPPER_CASE(ID) = "THEN" or UPPER_CASE(ID) = "TYPE" or UPPER_CASE(ID) = "WHEN" or UPPER_CASE(ID) = "WITH"; when 5 => ANSWER := UPPER_CASE(ID) = "ABORT" or UPPER_CASE(ID) = "ARRAY" or UPPER_CASE(ID) = "BEGIN" or UPPER_CASE(ID) = "DELAY" or UPPER_CASE(ID) = "DELTA" or UPPER_CASE(ID) = "ELSIF" or UPPER_CASE(ID) = "ENTRY" or UPPER_CASE(ID) = "RAISE" or UPPER_CASE(ID) = "RANGE" or UPPER_CASE(ID) = "WHILE"; when 6 => ANSWER := UPPER_CASE(ID) = "ACCEPT" or UPPER_CASE(ID) = "ACCESS" or UPPER_CASE(ID) = "DIGITS" or UPPER_CASE(ID) = "OTHERS" or UPPER_CASE(ID) = "PRAGMA" or UPPER_CASE(ID) = "RECORD" or UPPER_CASE(ID) = "RETURN" or UPPER_CASE(ID) = "SELECT"; when 7 => ANSWER := UPPER_CASE(ID) = "DECLARE" or UPPER_CASE(ID) = "GENERIC" or UPPER_CASE(ID) = "LIMITED" or UPPER_CASE(ID) = "PACKAGE" or UPPER_CASE(ID) = "PRIVATE" or UPPER_CASE(ID) = "RENAMES" or UPPER_CASE(ID) = "REVERSE" or UPPER_CASE(ID) = "SUBTYPE"; when 8 => ANSWER := UPPER_CASE(ID) = "CONSTANT" or UPPER_CASE(ID) = "FUNCTION" or UPPER_CASE(ID) = "SEPARATE"; when 9 => ANSWER := UPPER_CASE(ID) = "EXCEPTION" or UPPER_CASE(ID) = "PROCEDURE" or UPPER_CASE(ID) = "TERMINATE"; when OTHERS => ANSWER := FALSE; end case; return ANSWER; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("in IS_A_RESERVED_WORD"); raise; end IS_A_RESERVED_WORD; :::::::::: reservedw.ada :::::::::: separate (TOKENIZER) function RESERVED_WORD (ID : in DYN.DYN_STRING) return KEYWORDS is -------------------------------------------------------------------------- -- Abstract : This function returns the Keywords enumeration value of -- the input reserve word string. -------------------------------------------------------------------------- -- Parameters : ID - The string representation of some reserve word -------------------------------------------------------------------------- ANSWER : KEYWORDS; -- this is the return begin case DYN.LENGTH(ID) is when 2 => if UPPER_CASE(ID) = "AT" then ANSWER := AT_TOKEN; elsif UPPER_CASE(ID) = "DO" then ANSWER := DO_TOKEN; elsif UPPER_CASE(ID) = "IF" then ANSWER := IF_TOKEN; elsif UPPER_CASE(ID) = "IN" then ANSWER := IN_TOKEN; elsif UPPER_CASE(ID) = "IS" then ANSWER := IS_TOKEN; elsif UPPER_CASE(ID) = "OF" then ANSWER := OF_TOKEN; elsif UPPER_CASE(ID) = "OR" then ANSWER := OR_TOKEN; else raise INVALID_TOKEN; end if; when 3 => if UPPER_CASE(ID) = "ABS" then ANSWER := ABS_TOKEN; elsif UPPER_CASE(ID) = "ALL" then ANSWER := ALL_TOKEN; elsif UPPER_CASE(ID) = "AND" then ANSWER := AND_TOKEN; elsif UPPER_CASE(ID) = "END" then ANSWER := END_TOKEN; elsif UPPER_CASE(ID) = "FOR" then ANSWER := FOR_TOKEN; elsif UPPER_CASE(ID) = "MOD" then ANSWER := MOD_TOKEN; elsif UPPER_CASE(ID) = "NEW" then ANSWER := NEW_TOKEN; elsif UPPER_CASE(ID) = "NOT" then ANSWER := NOT_TOKEN; elsif UPPER_CASE(ID) = "OUT" then ANSWER := OUT_TOKEN; elsif UPPER_CASE(ID) = "REM" then ANSWER := REM_TOKEN; elsif UPPER_CASE(ID) = "USE" then ANSWER := USE_TOKEN; elsif UPPER_CASE(ID) = "XOR" then ANSWER := XOR_TOKEN; else raise INVALID_TOKEN; end if; when 4 => if UPPER_CASE(ID) = "BODY" then ANSWER := BODY_TOKEN; elsif UPPER_CASE(ID) = "CASE" then ANSWER := CASE_TOKEN; elsif UPPER_CASE(ID) = "ELSE" then ANSWER := ELSE_TOKEN; elsif UPPER_CASE(ID) = "EXIT" then ANSWER := EXIT_TOKEN; elsif UPPER_CASE(ID) = "GOTO" then ANSWER := GOTO_TOKEN; elsif UPPER_CASE(ID) = "LOOP" then ANSWER := LOOP_TOKEN; elsif UPPER_CASE(ID) = "NULL" then ANSWER := NULL_TOKEN; elsif UPPER_CASE(ID) = "TASK" then ANSWER := TASK_TOKEN; elsif UPPER_CASE(ID) = "THEN" then ANSWER := THEN_TOKEN; elsif UPPER_CASE(ID) = "TYPE" then ANSWER := TYPE_TOKEN; elsif UPPER_CASE(ID) = "WHEN" then ANSWER := WHEN_TOKEN; elsif UPPER_CASE(ID) = "WITH" then ANSWER := WITH_TOKEN; else raise INVALID_TOKEN; end if; when 5 => if UPPER_CASE(ID) = "ABORT" then ANSWER := ABORT_TOKEN; elsif UPPER_CASE(ID) = "ARRAY" then ANSWER := ARRAY_TOKEN; elsif UPPER_CASE(ID) = "BEGIN" then ANSWER := BEGIN_TOKEN; elsif UPPER_CASE(ID) = "DELAY" then ANSWER := DELAY_TOKEN; elsif UPPER_CASE(ID) = "DELTA" then ANSWER := DELTA_TOKEN; elsif UPPER_CASE(ID) = "ELSIF" then ANSWER := ELSIF_TOKEN; elsif UPPER_CASE(ID) = "ENTRY" then ANSWER := ENTRY_TOKEN; elsif UPPER_CASE(ID) = "RAISE" then ANSWER := RAISE_TOKEN; elsif UPPER_CASE(ID) = "RANGE" then ANSWER := RANGE_TOKEN; elsif UPPER_CASE(ID) = "WHILE" then ANSWER := WHILE_TOKEN; else raise INVALID_TOKEN; end if; when 6 => if UPPER_CASE(ID) = "ACCEPT" then ANSWER := ACCEPT_TOKEN; elsif UPPER_CASE(ID) = "ACCESS" then ANSWER := ACCESS_TOKEN; elsif UPPER_CASE(ID) = "DIGITS" then ANSWER := DIGITS_TOKEN; elsif UPPER_CASE(ID) = "OTHERS" then ANSWER := OTHERS_TOKEN; elsif UPPER_CASE(ID) = "PRAGMA" then ANSWER := PRAGMA_TOKEN; elsif UPPER_CASE(ID) = "RECORD" then ANSWER := RECORD_TOKEN; elsif UPPER_CASE(ID) = "RETURN" then ANSWER := RETURN_TOKEN; elsif UPPER_CASE(ID) = "SELECT" then ANSWER := SELECT_TOKEN; else raise INVALID_TOKEN; end if; when 7 => if UPPER_CASE(ID) = "DECLARE" then ANSWER := DECLARE_TOKEN; elsif UPPER_CASE(ID) = "GENERIC" then ANSWER := GENERIC_TOKEN; elsif UPPER_CASE(ID) = "LIMITED" then ANSWER := LIMITED_TOKEN; elsif UPPER_CASE(ID) = "PACKAGE" then ANSWER := PACKAGE_TOKEN; elsif UPPER_CASE(ID) = "PRIVATE" then ANSWER := PRIVATE_TOKEN; elsif UPPER_CASE(ID) = "RENAMES" then ANSWER := RENAMES_TOKEN; elsif UPPER_CASE(ID) = "REVERSE" then ANSWER := REVERSE_TOKEN; elsif UPPER_CASE(ID) = "SUBTYPE" then ANSWER := SUBTYPE_TOKEN; else raise INVALID_TOKEN; end if; when 8 => if UPPER_CASE(ID) = "CONSTANT" then ANSWER := CONSTANT_TOKEN; elsif UPPER_CASE(ID) = "FUNCTION" then ANSWER := FUNCTION_TOKEN; elsif UPPER_CASE(ID) = "SEPARATE" then ANSWER := SEPARATE_TOKEN; else raise INVALID_TOKEN; end if; when 9 => if UPPER_CASE(ID) = "EXCEPTION" then ANSWER := EXCEPTION_TOKEN; elsif UPPER_CASE(ID) = "PROCEDURE" then ANSWER := PROCEDURE_TOKEN; elsif UPPER_CASE(ID) = "TERMINATE" then ANSWER := TERMINATE_TOKEN; else raise INVALID_TOKEN; end if; when OTHERS => raise INVALID_TOKEN; end case; return ANSWER; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in RESERVED_WORD"); raise; end RESERVED_WORD; :::::::::: nextchara.ada :::::::::: separate (TOKENIZER) function NEXT_CHARACTER return CHARACTER is -- Gets next character from -- input file -------------------------------------------------------------------------- -- Abstract : This function returns the next character to be parsed -- by the tokenizer build_tokens procedure. This routine -- also translates horizontal tabs into the correct number -- of spaces (based on the constant TAB_LENGTH). -------------------------------------------------------------------------- TAB_LENGTH : constant NATURAL := 8; SPACES_TO_ADD : NATURAL; -- Used if tab is found procedure GET_LINE(LINE : out LINE_RECORD) is NEW_INPUT_LINE : LINE_STRING; -- parameters sent to TEXT_IO NEW_INPUT_LINE_LENGTH : LINE_COLUMN; begin if TEXT_IO.END_OF_FILE(INPUT_FILE) then CURRENT_LINE_NUMBER := CURRENT_LINE_NUMBER + 1; LINE.LENGTH := -1; LINE.COLUMN := 0; else CURRENT_LINE_NUMBER := CURRENT_LINE_NUMBER + 1; TEXT_IO.GET_LINE(INPUT_FILE,NEW_INPUT_LINE,NEW_INPUT_LINE_LENGTH); LINE.LINE(1..NEW_INPUT_LINE_LENGTH + 1) := NEW_INPUT_LINE(1..NEW_INPUT_LINE_LENGTH) & " "; LINE.COLUMN := 0; LINE.LENGTH := NEW_INPUT_LINE_LENGTH + 1; end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("in GET_LINE"); raise; end GET_LINE; begin if CURRENT_LINE.COLUMN < CURRENT_LINE.LENGTH then CURRENT_LINE.COLUMN := CURRENT_LINE.COLUMN + 1; if CURRENT_LINE.LINE(CURRENT_LINE.COLUMN) /= ASCII.HT then return CURRENT_LINE.LINE(CURRENT_LINE.COLUMN); else -- special case to handle tabs in input! CURRENT_LINE.LINE(CURRENT_LINE.COLUMN) := ' '; SPACES_TO_ADD := TAB_LENGTH - (CURRENT_LINE.COLUMN mod TAB_LENGTH); CURRENT_LINE.LINE(CURRENT_LINE.COLUMN + SPACES_TO_ADD.. CURRENT_LINE.LENGTH + SPACES_TO_ADD) := CURRENT_LINE.LINE(CURRENT_LINE.COLUMN..CURRENT_LINE.LENGTH); for I in 1..SPACES_TO_ADD loop CURRENT_LINE.LINE(CURRENT_LINE.COLUMN + I - 1) := ' '; end loop; CURRENT_LINE.LENGTH := CURRENT_LINE.LENGTH + SPACES_TO_ADD; return ' '; end if; elsif CURRENT_LINE.LENGTH > -1 then GET_LINE(CURRENT_LINE); if CURRENT_LINE_NUMBER /= 1 then raise END_LINE; else -- if CURRENT_LINE_NUMBER is 1 then this is the first time -- through NEXT_CHARACTER, so get next character return NEXT_CHARACTER; end if; else raise END_FILE; end if; exception when END_LINE | END_FILE => raise; -- Let 'em go when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("in NEXT_CHARACTER"); raise; end NEXT_CHARACTER; :::::::::: nextident.ada :::::::::: separate (TOKENIZER) function NEXT_IDENTIFIER return TOKEN is -- Gets next token from input -------------------------------------------------------------------------- -- Abstract : This function builds the next token from the input stream. -------------------------------------------------------------------------- CURRENT_CHARACTER : CHARACTER; INDEX : LINE_INDEX_RANGE; BUILD_A_TOKEN : TOKEN_POINTER; TEMPORARY_ID : STRING(1..LINE_INDEX_RANGE'last); TEMPORARY_ID_LENGTH : LINE_INDEX_RANGE := 0; function LOOK_AHEAD(CHARACTER_COUNT : in LINE_COLUMN := 1) return CHARACTER is begin if (CURRENT_LINE.COLUMN + CHARACTER_COUNT <= CURRENT_LINE.LENGTH) then return CURRENT_LINE.LINE(CURRENT_LINE.COLUMN + CHARACTER_COUNT); else return ' '; end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in LOOK_AHEAD"); raise; end LOOK_AHEAD; procedure PUSH_BACK_CHARACTER is begin if (CURRENT_LINE.COLUMN - 1 > 0) then CURRENT_LINE.COLUMN := CURRENT_LINE.COLUMN - 1; end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in PUSH_BACK_CHARACTER"); raise; end PUSH_BACK_CHARACTER; begin BUILD_A_TOKEN := new TOKEN; BUILD_A_TOKEN.NEXT_TOKEN := null; BUILD_A_TOKEN.PREVIOUS_TOKEN := null; -- Set the column to the length of the current line in case END_LINE or -- END_FILE is raised by NEXT_CHARACTER if CURRENT_LINE.LENGTH > 0 then BUILD_A_TOKEN.TOKEN_POSITION.COLUMN := CURRENT_LINE.LENGTH - 1; else BUILD_A_TOKEN.TOKEN_POSITION.COLUMN := 0; end if; begin -- block to handle exceptions raised by NEXT_CHARACTER CURRENT_CHARACTER := NEXT_CHARACTER; while CURRENT_CHARACTER = ' ' loop CURRENT_CHARACTER := NEXT_CHARACTER; end loop; BUILD_A_TOKEN.TOKEN_POSITION.LINE := CURRENT_LINE_NUMBER; BUILD_A_TOKEN.TOKEN_POSITION.COLUMN := CURRENT_LINE.COLUMN; case CURRENT_CHARACTER is when '&' => BUILD_A_TOKEN.TYPE_OF_TOKEN := CONCATENATION_OPERATOR; when ')' => BUILD_A_TOKEN.TYPE_OF_TOKEN := RIGHT_PARENTHESIS; when '(' => BUILD_A_TOKEN.TYPE_OF_TOKEN := LEFT_PARENTHESIS; when '+' => BUILD_A_TOKEN.TYPE_OF_TOKEN := ADDITION_OPERATOR; when ',' => BUILD_A_TOKEN.TYPE_OF_TOKEN := COMMA; when ';' => BUILD_A_TOKEN.TYPE_OF_TOKEN := SEMICOLON; when '|' => BUILD_A_TOKEN.TYPE_OF_TOKEN := VERTICAL_BAR; when '.' => if (LOOK_AHEAD = '.') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := DOUBLE_DOT; else BUILD_A_TOKEN.TYPE_OF_TOKEN := PERIOD; end if; when ':' => if (LOOK_AHEAD = '=') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := ASSIGNMENT_OPERATOR; else BUILD_A_TOKEN.TYPE_OF_TOKEN := COLON; end if; when '-' => if (LOOK_AHEAD = '-') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := COMMENT; CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.PHYSICAL_REPRESENTATION := DYN.D_STRING(CURRENT_LINE.LINE( CURRENT_LINE.COLUMN..CURRENT_LINE.LENGTH)); CURRENT_LINE.COLUMN := CURRENT_LINE.LENGTH; else BUILD_A_TOKEN.TYPE_OF_TOKEN := SUBTRACTION_OPERATOR; end if; when '*' => if (LOOK_AHEAD = '*') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := EXPONENTIATE_OPERATOR; else BUILD_A_TOKEN.TYPE_OF_TOKEN := MULTIPLICATION_OPERATOR; end if; when '=' => if (LOOK_AHEAD = '>') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := ARROW; else BUILD_A_TOKEN.TYPE_OF_TOKEN := EQUAL_OPERATOR; end if; when '/' => if (LOOK_AHEAD = '=') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := INEQUAL_OPERATOR; else BUILD_A_TOKEN.TYPE_OF_TOKEN := DIVISION_OPERATOR; end if; when '>' => if (LOOK_AHEAD = '=') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := GREATER_THAN_OR_EQUAL_OPERATOR; elsif (LOOK_AHEAD = '>') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := RIGHT_LABEL_BRACKET; else BUILD_A_TOKEN.TYPE_OF_TOKEN := GREATER_THAN_OPERATOR; end if; when '<' => if (LOOK_AHEAD = '=') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := LESS_THAN_OR_EQUAL_OPERATOR; elsif (LOOK_AHEAD = '>') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := BOX; elsif (LOOK_AHEAD = '<') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.TYPE_OF_TOKEN := LEFT_LABEL_BRACKET; else BUILD_A_TOKEN.TYPE_OF_TOKEN := LESS_THAN_OPERATOR; end if; when ''' => if (LOOK_AHEAD(2) = ''') then CURRENT_CHARACTER := NEXT_CHARACTER; BUILD_A_TOKEN.PHYSICAL_REPRESENTATION := DYN.D_STRING(CURRENT_CHARACTER); CURRENT_CHARACTER := NEXT_CHARACTER;-- skip tick BUILD_A_TOKEN.TYPE_OF_TOKEN := CHARACTER_LITERAL; else BUILD_A_TOKEN.TYPE_OF_TOKEN := TICK; end if; when '"' => CURRENT_CHARACTER := NEXT_CHARACTER; begin -- block to handle unexpected end of line in incorrect -- input code BUILD_A_TOKEN.TYPE_OF_TOKEN := STRING_LITERAL; while CURRENT_CHARACTER /= '"' loop TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; end loop; BUILD_A_TOKEN.PHYSICAL_REPRESENTATION := DYN.D_STRING(TEMPORARY_ID(1..TEMPORARY_ID_LENGTH)); exception when END_LINE => BUILD_A_TOKEN.TYPE_OF_TOKEN := END_OF_LINE; when END_FILE => BUILD_A_TOKEN.TYPE_OF_TOKEN := END_OF_FILE; BUILD_A_TOKEN.PHYSICAL_REPRESENTATION := DYN.D_STRING(TEXT_IO.NAME(INPUT_FILE)); when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE ("in block to handle quoted string"); raise; end; when 'A' .. 'Z' | 'a' .. 'z' => begin -- block to handle end of line or end of file while ((CURRENT_CHARACTER >= 'A') and (CURRENT_CHARACTER <= 'Z')) or ((CURRENT_CHARACTER >= 'a') and (CURRENT_CHARACTER <= 'z')) or ((CURRENT_CHARACTER >= '0') and (CURRENT_CHARACTER <= '9')) or (CURRENT_CHARACTER = '_') loop TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; end loop; if CURRENT_CHARACTER /= ' ' then PUSH_BACK_CHARACTER; -- last character not part of end if; -- ID and not "parsed" exception -- when END_FILE | END_LINE => null; -- ok exceptions when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("in block to handle identifiers "); raise; end; BUILD_A_TOKEN.PHYSICAL_REPRESENTATION := DYN.D_STRING(TEMPORARY_ID(1..TEMPORARY_ID_LENGTH)); if IS_A_RESERVED_WORD(BUILD_A_TOKEN.PHYSICAL_REPRESENTATION) then BUILD_A_TOKEN.TYPE_OF_TOKEN := RESERVED_WORD(BUILD_A_TOKEN.PHYSICAL_REPRESENTATION); else BUILD_A_TOKEN.TYPE_OF_TOKEN := IDENTIFIER; end if; when '0' .. '9' => begin -- block to handle end of line or end of file while ((CURRENT_CHARACTER >= '0') and (CURRENT_CHARACTER <= '9')) or (CURRENT_CHARACTER = '_') loop TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; case CURRENT_CHARACTER is when '.' => -- skip decimal point if (LOOK_AHEAD >= '0') and (LOOK_AHEAD <= '9') then TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; end if; when 'E' | 'e' => -- skip E and optional sign TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; if (CURRENT_CHARACTER = '-') or (CURRENT_CHARACTER = '+') then TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; end if; when '#' => -- based literal TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; -- There is a chance that we will skip over -- valid tokens searching for closing '#' if it -- is missing, but ill formed inpute is NOT our -- problem. while (CURRENT_CHARACTER /= '#') loop TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; end loop; -- Now stick # into ID and continue TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; if (CURRENT_CHARACTER = 'E') or (CURRENT_CHARACTER = 'e') then -- skip E and optional sign TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; if (CURRENT_CHARACTER = '-') or (CURRENT_CHARACTER = '+') then TEMPORARY_ID_LENGTH := TEMPORARY_ID_LENGTH + 1; TEMPORARY_ID(TEMPORARY_ID_LENGTH) := CURRENT_CHARACTER; CURRENT_CHARACTER := NEXT_CHARACTER; end if; end if; when others => null; end case; end loop; if CURRENT_CHARACTER /= ' ' then PUSH_BACK_CHARACTER; -- last character not part of end if; -- number and not "parsed" exception -- when END_FILE | END_LINE => null; -- ok exceptions when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("in block to handle numeric " & "literals"); raise; end; BUILD_A_TOKEN.PHYSICAL_REPRESENTATION := DYN.D_STRING(TEMPORARY_ID(1..TEMPORARY_ID_LENGTH)); BUILD_A_TOKEN.TYPE_OF_TOKEN := NUMERIC_LITERAL; when others => BUILD_A_TOKEN.PHYSICAL_REPRESENTATION := DYN.D_STRING(CURRENT_CHARACTER); BUILD_A_TOKEN.TYPE_OF_TOKEN := ANYTHING_ELSE; end case; exception when END_LINE => BUILD_A_TOKEN.TOKEN_POSITION.LINE := CURRENT_LINE_NUMBER - 1; BUILD_A_TOKEN.TYPE_OF_TOKEN := END_OF_LINE; when END_FILE => BUILD_A_TOKEN.TOKEN_POSITION.LINE := CURRENT_LINE_NUMBER; BUILD_A_TOKEN.TYPE_OF_TOKEN := END_OF_FILE; BUILD_A_TOKEN.PHYSICAL_REPRESENTATION := DYN.D_STRING(TEXT_IO.NAME(INPUT_FILE)); when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("in NEXT_IDENTIFIER"); raise; end; return BUILD_A_TOKEN.all; end NEXT_IDENTIFIER; :::::::::: buildtoke.ada :::::::::: separate (TOKENIZER) procedure BUILD_TOKENS is -------------------------------------------------------------------------- -- Abstract : This is the procedure that builds the token stream from -- the input Ada source file(s). -------------------------------------------------------------------------- CURRENT_TOKEN : TOKEN_POINTER; LAST_TOKEN : TOKEN_POINTER; MORE_FILES : BOOLEAN := TRUE; begin ROOT_TOKEN := null; LAST_TOKEN := null; FILE_HANDLING.INPUT_FILE_ID(INPUT_FILE,MORE_FILES); while MORE_FILES loop CURRENT_LINE_NUMBER := 0; CURRENT_LINE.LENGTH := 0; CURRENT_LINE.COLUMN := 0; loop CURRENT_TOKEN := new TOKEN; CURRENT_TOKEN.all := NEXT_IDENTIFIER; if TYPE_OF_TOKEN_IS(CURRENT_TOKEN.all) = IDENTIFIER then INSERT(CURRENT_TOKEN.PHYSICAL_REPRESENTATION,ROOT); end if; if ROOT_TOKEN = null then ROOT_TOKEN := CURRENT_TOKEN; LAST_TOKEN := CURRENT_TOKEN; else LAST_TOKEN.NEXT_TOKEN := CURRENT_TOKEN; CURRENT_TOKEN.PREVIOUS_TOKEN := LAST_TOKEN; LAST_TOKEN := CURRENT_TOKEN; end if; exit when TYPE_OF_TOKEN_IS(CURRENT_TOKEN.all) = END_OF_FILE; end loop; FILE_HANDLING.INPUT_FILE_ID(INPUT_FILE,MORE_FILES); end loop; exception when FILE_HANDLING.HELP_ASKED_FOR => raise; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in BUILD_TOKENS"); raise; end BUILD_TOKENS; :::::::::: lineconta.ada :::::::::: separate (TOKENIZER) procedure LINE_CONTAINING_TOKEN(CURRENT_TOKEN : in TOKEN; LINE : out DYN.DYN_STRING) is -------------------------------------------------------------------------- -- Abstract : This procedure builds the source line containing the input -- token by scanning the tokens in each direction. -------------------------------------------------------------------------- -- Parameters : CURRENT_TOKEN - token to build line for -- LINE - Copy of input line -------------------------------------------------------------------------- RETURN_STRING : LINE_STRING := (1..LINE_STRING'length => ' '); STRING_LENGTH : LINE_INDEX_RANGE := 0; CUR_TOKEN : TOKEN; begin CUR_TOKEN := CURRENT_TOKEN; -- get to the token that ends the line before the line containing this token -- block to encapsulate PREVIOUS_TOKEN calls in case this is the first -- line of the source file begin while CUR_TOKEN.TOKEN_POSITION.LINE = CURRENT_TOKEN.TOKEN_POSITION.LINE loop CUR_TOKEN := PREVIOUS_TOKEN(CUR_TOKEN); end loop; CUR_TOKEN := NEXT_TOKEN(CUR_TOKEN); exception when END_OF_TOKENS => -- will be raised if this is 1st null; -- line when others => raise; end; -- CUR_TOKEN should now point to the first token of the line while (TYPE_OF_TOKEN_IS(CUR_TOKEN) /= END_OF_LINE) and (TYPE_OF_TOKEN_IS(CUR_TOKEN) /= END_OF_FILE) loop RETURN_STRING(CUR_TOKEN.TOKEN_POSITION.COLUMN .. (CUR_TOKEN.TOKEN_POSITION.COLUMN - 1) + DYN.LENGTH(EXTERNAL_REPRESENTATION(CUR_TOKEN))) := DYN.STR(EXTERNAL_REPRESENTATION(CUR_TOKEN)); STRING_LENGTH := (CUR_TOKEN.TOKEN_POSITION.COLUMN - 1) + DYN.LENGTH(EXTERNAL_REPRESENTATION(CUR_TOKEN)); CUR_TOKEN := NEXT_TOKEN(CUR_TOKEN); end loop; LINE := DYN.D_STRING(RETURN_STRING(1..STRING_LENGTH)); exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in LINE_CONTAINING_TOKEN"); raise; end LINE_CONTAINING_TOKEN; :::::::::: treeroot.ada :::::::::: separate (TOKENIZER) function TREE_ROOT return IDENTIFIER_TREE is -------------------------------------------------------------------------- -- Abstract : This function returns the root of the binary tree created -- by the tokenizer -------------------------------------------------------------------------- begin return ROOT; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in TREE_ROOT"); raise; end TREE_ROOT; :::::::::: SPARAMBOD.ADA :::::::::: Package body Style_Parameters is use TOKENIZER; type Package_Name_Node; type Package_List is access Package_Name_node; type Package_Name_Node is record P_Name : DYN.DYN_STRING; Next : Package_List; end record; ERRORS_TO_LIST : Natural := 5; KEYWORD_OUTPUT : Keyword_Options := None; OPERATOR_OUTPUT: boolean; SHORT_PROGRAM : Natural := 100; -- Any program this length or shorter -- may ignore limits when checking -- complexity, keyword frequency, -- etc. SHORT_WORD : Word_Lengths := 6; -- Any word this length or shorter -- may ignore Limits when checking -- underscores and vowels. SHORT_STRUCTURE : Natural := 5; -- Any structure this length or shorter -- may ignore style when checking for -- surrounding blank lines or -- loop names. RESERVED_CASE : Reserve_Word_Cases := Reserved_Case_Lower; OBJECT_CASE : Object_Name_Cases := Name_Case_Upper; NAME_LENGTH_AVE : Word_Lengths range 1..Word_Lengths'last := 5; UNDERSCORE_REQUIRED : boolean; UNDERSCORE_LENGTH_AVE : Word_Lengths range 1..Word_Lengths'last := Name_Length_Ave; ABBREV_AVE : Abbreviation_Aves := 0.35; SPELLING_REQUIREMENT : Require_Type := Not_Required; -- Physical Layout ONE_LINE_PER_STATEMENT : boolean; -- Indentation -- Initial on line is Always Required! No parameter! TYPE_INDENTATION : boolean; COMMENT_INDENTATION : boolean; -- Blank Space BLANKS_AROUND_BLOCKS : boolean; BLANK_LINE_PERCENT : float := 0.20; PROLOG_NEEDED : boolean; LOOP_NAME_NEEDED : Loop_Names_Needs; LOOP_NAME_PERCENT : float := 0.30; -- 30% of loops have names. -- Statement USE KEYWRD_ARRAY : Keyword_Uses; AVE_SIZE_OF_COMMENT : Positive := 15; -- Average chars/comment -- Information hiding, abstraction, data use -- constants/literals in code vs. specification LITERAL_FREQ_IN_BODY : Float := 0.10; -- 90% should be in spec. -- Should declare own types UNIVERSAL_TYPE_USAGE : Float := 0.40; -- Just a WAG -- Should use enumeration and record facilities DATA_STRUCTURE_USE : boolean := TRUE; -- Do we check for structures? ATTRIBUTE_USE : Require_Type := Required; -- or attributes? -- Modularity LOWER_PARAMETER_SIZE : Natural := 1; UPPER_PARAMETER_SIZE : Natural := 8; LOWER_SUBPROGRAM_SIZE : Natural := 10; UPPER_SUBPROGRAM_SIZE : Natural := 200; -- Complexity KEYWORD_TYPES_USED : float := 0.65; -- This applies when program -- is not 'short'. # keywords -- is Number_of_Keywords; CONTROL_NESTING_LIMIT : Natural := 8; SUBPROGRAM_NESTING_LIMIT: Natural := 4; PACKAGE_NESTING_LIMIT : Natural := 2; MAX_LOOP_EXITS : Natural := 1; -- Structured programming df LINE_SIZE_LIMIT : Positive := 80; CHAR_SET_ALLOWED : Character_Set_Types := Graphic; REP_SPECS_PERMITTED : boolean := TRUE; ADDR_CLAUSES_PERMITTED : boolean := TRUE; PRAGMAS_TO_BE_NOTED : Pragma_Classes := System_Dependent; PROSCRIBED : constant array (1.. 5) of DYN.DYN_STRING := (DYN.D_STRING("SYSTEM"), DYN.D_STRING("TTY_IO"), DYN.D_STRING("UNCHECKED_CONVERSION"), DYN.D_STRING("UNCHECKED_DEALLOCATION"), DYN.D_STRING("CURRENT_EXCEPTION")); ------------------------------------- -- This procedure obtains the 'style ------------------------------------- Procedure Set_Style_Parameters is -- This sets the parameter variables TEMP_PACKAGE : Package_List; END_OF_PACKAGE_LIST : Package_List; KWD_DEFAULT : Keyword_Use_Descript := (Use_Class => Free_Use, Use_Freq => 0.0); begin ERRORS_TO_LIST := 10; KEYWORD_OUTPUT := Used; OPERATOR_OUTPUT := FALSE; SHORT_PROGRAM := 100; SHORT_WORD := 6; SHORT_STRUCTURE := 5; RESERVED_CASE := Reserved_Case_Lower; OBJECT_CASE := Name_Case_Upper; NAME_LENGTH_AVE := 5; UNDERSCORE_REQUIRED := TRUE; UNDERSCORE_LENGTH_AVE := 5; ABBREV_AVE := 0.35; SPELLING_REQUIREMENT := Not_Required; ONE_LINE_PER_STATEMENT := TRUE; TYPE_INDENTATION := TRUE; COMMENT_INDENTATION := FALSE; BLANKS_AROUND_BLOCKS := TRUE; LOOP_NAME_NEEDED := Required; LOOP_NAME_PERCENT := 0.30; AVE_SIZE_OF_COMMENT := 15; LITERAL_FREQ_IN_BODY := 0.30; UNIVERSAL_TYPE_USAGE := 0.40; DATA_STRUCTURE_USE := TRUE; ATTRIBUTE_USE := Required; LOWER_PARAMETER_SIZE := 0; UPPER_PARAMETER_SIZE := 4; LOWER_SUBPROGRAM_SIZE := 10; UPPER_SUBPROGRAM_SIZE := 200; CONTROL_NESTING_LIMIT := 8; SUBPROGRAM_NESTING_LIMIT := 4; PACKAGE_NESTING_LIMIT := 2; MAX_LOOP_EXITS := 1; -- Structured programming df LINE_SIZE_LIMIT := 80; CHAR_SET_ALLOWED := Graphic; REP_SPECS_PERMITTED := FALSE; ADDR_CLAUSES_PERMITTED := FALSE; -- KEYWRD_ARRAY := TBD; For kwd in TOKENIZER.KEYWORDS loop KEYWRD_ARRAY(kwd) := KWD_DEFAULT; end loop; KEYWRD_ARRAY( TOKENIZER.KEYWORDS'(TOKENIZER.GOTO_TOKEN) ):= (Use_Class => No_Use, Use_Freq => 0.00); KEYWRD_ARRAY( TOKENIZER.USE_TOKEN ) := (Use_Class => Restricted_Use, Use_Freq => 0.20); PRAGMAS_TO_BE_NOTED := All_Pragmas; -- Set of the LIST of PROSCRIBED ('bad') PACKAGES -- These packages are defined by the constant array PROSCRIBED, above. -- To change the proscribed packages, change that array. end; -------------------------------------------- -- These return style individual parameters -------------------------------------------- function Number_of_Errors_to_Report return natural is -- This returns a number telling how many times to list -- a error in the "Flaws" output. I.E. If this returns -- "3", then only the first three occurences of each -- type of error are listed. begin return ERRORS_TO_LIST; end; function OUTPUT_KEYWORD_LIST return Keyword_Options is -- This function returns a value specifying the output format for -- listing the reserved word usage. It specifys which class of -- reserved words to output, all keywords, only those keywords -- used or not used, keywords used in violation of style restrictions, -- or no keywords output. begin return KEYWORD_OUTPUT; end; function OUTPUT_OPERATOR_LIST return boolean is -- This function returns true if the operator list is to be printed -- as part of the style report. begin return OPERATOR_OUTPUT; end; function SMALL_PROGRAM_SIZE return natural is -- returns size of programs considered 'too small' so limits of -- some things may be violated with not penalty. begin return SHORT_PROGRAM; end; function Small_Word_Size return Word_Lengths is -- returns size of words considered 'too small' so limits of -- some things may be violated with no penalty. begin return SHORT_WORD; end; function Small_Structure_Size return Natural is -- returns size (in statements) of structures considered 'too small' so -- some constraints may be violated with no penalty. begin return SHORT_STRUCTURE; end; function Case_of_Reserved_Words return Reserve_Word_Cases is begin return RESERVED_CASE; end; function Case_of_Object_Names return Object_Name_Cases is begin return OBJECT_CASE; end; function Average_Name_Size return Word_Lengths is -- The average size of names in the program should be greater than -- this minimum. begin return NAME_LENGTH_AVE; end; function Is_Underscore_Required return boolean is begin return UNDERSCORE_REQUIRED; end; function Average_Underscore_Size return Word_Lengths is -- If underscores are required and the word under inspection is -- longer than a "Small_Word", then the parts separated by -- underscores should be longer than this minimum. begin return UNDERSCORE_LENGTH_AVE; end; function Vowel_Frequency return float is -- To keep people from abbreviating too much, check the percentage of -- vowels to consonants. If (Vowel / Total-letters) is less than -- Vowel_Frequency percent, there is something wrong. begin return ABBREV_AVE; end; function SPELLING_REQUIRED return Require_Type is -- This function returns 'Required' if the style checker is to -- send words to a spelling checker to validate variable names. begin return SPELLING_REQUIREMENT; end; function Is_One_Statement_per_line_Required return boolean is begin return ONE_LINE_PER_STATEMENT; end; function Is_Declaration_Indentation_Required return boolean is -- Forced to indent properly on object, type declarations? begin return TYPE_INDENTATION; end; function Is_Comment_Indentation_Required return boolean is -- Forced to indent the trailing comments after statement on a line? begin return COMMENT_INDENTATION; end; function Is_Blank_Lines_around_Blocks_Required return boolean is -- Should blank lines around blocks, loops, etc. be required? begin return BLANKS_AROUND_BLOCKS; end; -- I think we deleted this function! -- function Average_Blank_Lines return float is -- -- The average # of blank lines should be 'Ave-blank-lines' +- delta -- -- for readability's sake -- begin -- return ; -- end; function Loop_Name_Required return Loop_Names_Needs is -- Are loop-names necessary, should loops of a certain size need names. begin return LOOP_NAME_NEEDED; end; procedure Reserved_Word_Info ( Usage : out Keyword_Uses ) is begin Usage := KEYWRD_ARRAY; end; function Average_Comment_Size return positive is -- To prevent style "tricking" comments must have a minimum average -- size; begin return AVE_SIZE_OF_COMMENT; end; function Average_Literal_in_Body return float is -- Literals should be in the declaration rather then the body, so -- the number of literals in the body should be less than "ave-literal" begin return LITERAL_FREQ_IN_BODY; end; function Average_Universal_Usage return float is -- In general, good use should be made of programmer-defined types -- rather than universal integer, float, etc. The percentage of -- types which are universal integer, float, natural, positive, etc. -- should be less then "ave-universals" begin return UNIVERSAL_TYPE_USAGE; end; function Is_Data_Structure_Use_Required return boolean is -- Should we check for enumeration types, records? begin return DATA_STRUCTURE_USE; end; function ATTRIBUTE_CHECK return Require_Type is -- This function tells whether the style checker notes the -- use of attributes. begin return ATTRIBUTE_USE; end; procedure Average_Subprogram_Size (SMALL_LIMIT : out Natural; LARGE_LIMIT : out Natural ) is begin SMALL_LIMIT := LOWER_SUBPROGRAM_SIZE; LARGE_LIMIT := UPPER_SUBPROGRAM_SIZE; end AVERAGE_SUBPROGRAM_SIZE; procedure SUBPROGRAM_PARAMETERS (SMALL_LIMIT : out Natural; LARGE_LIMIT : out Natural ) is begin SMALL_LIMIT := LOWER_PARAMETER_SIZE; LARGE_LIMIT := UPPER_PARAMETER_SIZE; end SUBPROGRAM_PARAMETERS; function CONTROL_NESTING_LEVEL return natural is -- This is the expected depth of nesting of control structures. begin return CONTROL_NESTING_LIMIT; end; function PACKAGE_NESTING_LEVEL return natural is -- This is the expected depth of nesting of packages. begin return PACKAGE_NESTING_LIMIT; end; function SUBPROGRAM_NESTING_LEVEL return natural is -- This is the expected depth of nesting of subprograms. begin return SUBPROGRAM_NESTING_LIMIT; end; function NUMBER_OF_LOOP_EXITS return natural is -- This number is a limit on the number of exits from a loop. begin return MAX_LOOP_EXITS; end; function LINE_SIZE return natural is -- This number is a limit on the number of characters in a line. begin return LINE_SIZE_LIMIT; end; function CHARACTER_SET return Character_Set_Types is -- This enumeration type determines the characters which are -- not flagged as style errors. This is to limit use of -- graphic or extended characters which may not transport to -- other machines. begin return CHAR_SET_ALLOWED; end; function REPRESENTATION_SPECS_ALLOWED return boolean is -- This returns true if rep specs are allowed in the style. begin return REP_SPECS_PERMITTED; end; function ADDRESS_CLAUSE_ALLOWED return boolean is -- This returns true if address clauses are allowed in the style. begin return ADDR_CLAUSES_PERMITTED; end; function NOTE_PRAGMAS return Pragma_Classes is -- This is an enumeration type defining which pragmas (all, system- -- dependent, or none) are illegal as defined in the style begin return PRAGMAS_TO_BE_NOTED; end; function DYN_EQUAL(STR1 : in DYN.DYN_STRING;STR2: in DYN.DYN_STRING) return boolean is begin if DYN.LENGTH(STR1) = DYN.LENGTH(STR2) then return DYN.STR(STR1) = DYN.STR(STR2); else return false; end if; end DYN_EQUAL; function IS_A_PREDEFINED_PRAGMA (NAME : in DYN.DYN_STRING ) return boolean is -- This returns true if the input name is a predefined pragma as listed -- in the LRM appendix B. PRAGMA_PREDEFINED : constant array (1..14) of DYN.DYN_STRING := (DYN.D_STRING("CONTROLLED"), DYN.D_STRING("ELABORATE"), DYN.D_STRING("INLINE"), DYN.D_STRING("INTERFACE"), DYN.D_STRING("LIST"), DYN.D_STRING("MEMORY_SIZE"), DYN.D_STRING("OPTIMIZE"), DYN.D_STRING("PACK"), DYN.D_STRING("PAGE"), DYN.D_STRING("PRIORITY"), DYN.D_STRING("SHARED"), DYN.D_STRING("STORAGE_UNIT"), DYN.D_STRING("SUPPRESS"), DYN.D_STRING("SYSTEM_NAME") ); begin for I in PRAGMA_PREDEFINED'FIRST..PRAGMA_PREDEFINED'LAST loop if DYN_EQUAL( NAME, PRAGMA_PREDEFINED(I)) then return true; end if; end loop; return false; end IS_A_PREDEFINED_PRAGMA; function IS_A_PROSCRIBED_PACKAGE (NAME : in DYN.DYN_STRING) return boolean is -- This returns true if the input name is a package on the -- list of 'stylistically incorrect' packages as defined by the style. begin for I in PROSCRIBED'FIRST..PROSCRIBED'LAST loop if DYN_EQUAL(NAME, PROSCRIBED(I) ) then return true; end if; end loop; return false; end IS_A_PROSCRIBED_PACKAGE; begin Set_Style_Parameters; end Style_Parameters; :::::::::: repgenbod.ada :::::::::: with CURRENT_EXCEPTION; package body REPORT_GENERATOR is -------------------------------------------------------------------------- -- Abstract : This is the package body for all the report routines. -------------------------------------------------------------------------- ERROR_OCCURRENCE_COUNT : array (ERRORS) of NATURAL := (ERRORS'FIRST .. ERRORS'LAST => 0); ADA_SPECIFICS_USED : BOOLEAN := FALSE; procedure PUT_FLAW(TO_THIS : in TEXT_IO.FILE_TYPE; BAD_TOKEN : in TOKENIZER.TOKEN; ERROR_MESSAGE : in DYN.DYN_STRING; ERROR_TYPE : in ERRORS := OTHER) is -------------------------------------------------------------------------- -- Abstract : This routine adds a flaw to the flaws listing file. -------------------------------------------------------------------------- -- Parameters : TO_THIS - File of Flaws list -- BAD_TOKEN - Token that points out the flaw -- ERROR_MESSAGE - The error message -- ERROR_TYPE - The type of the error -------------------------------------------------------------------------- BAD_LINE : DYN.DYN_STRING; begin ERROR_OCCURRENCE_COUNT(ERROR_TYPE) := ERROR_OCCURRENCE_COUNT(ERROR_TYPE) + 1; if (ERROR_OCCURRENCE_COUNT(ERROR_TYPE) <= STYLE_PARAMETERS.NUMBER_OF_ERRORS_TO_REPORT) or (ERROR_TYPE > NON_STANDARD_PRAGMA_USED) then TOKENIZER.LINE_CONTAINING_TOKEN(BAD_TOKEN,BAD_LINE); TEXT_IO.PUT_LINE(TO_THIS,DYN.STR(BAD_LINE)); TEXT_IO.PUT_LINE(TO_THIS,DYN.STR(ERROR_MESSAGE)); TEXT_IO.NEW_LINE(TO_THIS); end if; end PUT_FLAW; procedure PUT_FLAW(TO_THIS : in TEXT_IO.FILE_TYPE; BAD_TOKEN : in TOKENIZER.TOKEN; ERROR_MESSAGE : in STRING; ERROR_TYPE : in ERRORS := OTHER) is -------------------------------------------------------------------------- -- Abstract : This routine adds a flaw to the flaws listing file. -------------------------------------------------------------------------- -- Parameters : TO_THIS - File of Flaws list -- BAD_TOKEN - Token that points out the flaw -- ERROR_MESSAGE - The error message -- ERROR_TYPE - The type of the error -------------------------------------------------------------------------- BAD_LINE : DYN.DYN_STRING; begin ERROR_OCCURRENCE_COUNT(ERROR_TYPE) := ERROR_OCCURRENCE_COUNT(ERROR_TYPE) + 1; if (ERROR_OCCURRENCE_COUNT(ERROR_TYPE) <= STYLE_PARAMETERS.NUMBER_OF_ERRORS_TO_REPORT) or (ERROR_TYPE > NON_STANDARD_PRAGMA_USED) then TOKENIZER.LINE_CONTAINING_TOKEN(BAD_TOKEN,BAD_LINE); TEXT_IO.PUT_LINE(TO_THIS,DYN.STR(BAD_LINE)); TEXT_IO.PUT_LINE(TO_THIS,ERROR_MESSAGE); TEXT_IO.NEW_LINE(TO_THIS); end if; end PUT_FLAW; procedure GENERATE_REPORT(FROM_THIS : in REPORT_RECORD; TO_THIS : in TEXT_IO.FILE_TYPE; FILE_NAME : in DYN.DYN_STRING ) is -------------------------------------------------------------------------- -- Abstract : This routine generates the final error report for the -- Style_Checker. -------------------------------------------------------------------------- -- Parameters : FROM_THIS - Record of errors -- TO_THIS - Output file -- FILE_NAME - Name of input file -------------------------------------------------------------------------- use STYLE_PARAMETERS; package NATURAL_IO is new TEXT_IO.INTEGER_IO(NATURAL); package MY_FLOAT_IO is new TEXT_IO.FLOAT_IO(FLOAT); -- Column constants DECIMAL_POINT_COLUMN : constant NATURAL := 58; ERROR_FLAG_COLUMN : constant NATURAL := 3; FIRST_COLUMN_START : constant NATURAL := 7; SECOND_COLUMN_START : constant NATURAL := 44; THIRD_COLUMN_START : constant NATURAL := 64; -- String constants used again and again ACTUAL : constant STRING := "Actual"; ASTERIK : constant STRING := "*"; CHARACTERS : constant STRING := "Characters"; COMMENTS : constant STRING := "Comments"; DESIRED : constant STRING := "Desired"; DOT_DOT : constant STRING := ".."; ERRORS : constant STRING := "Errors"; EXCEEDED : constant STRING := "Exceeded"; EXCLAMATION : constant STRING := "!"; GREATER_THAN : constant CHARACTER := '>'; HEADER_LINE : constant STRING(1 .. 74) := (1 .. 74 => '-'); INSTANCES : constant STRING := "Instances"; LESS_THAN : constant CHARACTER := '<'; MAXIMUM : constant STRING := "Maximum"; PARAMETERS : constant STRING := "Parameters"; PERCENT : constant STRING := "%"; STATEMENTS : constant STRING := "Statements"; ASCII_IMAGE : STRING(1..5); COLUMN : POSITIVE; KEYWORD_COUNT : NATURAL := 0; type KEYWORD_PERCENTAGE_ARRAY is array(TOKENIZER.TOKEN_TYPE) of FLOAT; KEYWORD_PERCENTAGES : KEYWORD_PERCENTAGE_ARRAY := (TOKENIZER.TOKEN_TYPE'FIRST .. TOKENIZER.TOKEN_TYPE'LAST => 0.0); procedure PUT_REPORT_LINE(INDENTION : in NATURAL; HEADER : in STRING; ASTERIK_NEEDED : in BOOLEAN := FALSE; EXCLAMATION_NEEDED: in BOOLEAN := FALSE) is begin if ASTERIK_NEEDED then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(ERROR_FLAG_COLUMN)); TEXT_IO.PUT(TO_THIS,ASTERIK); elsif EXCLAMATION_NEEDED then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(ERROR_FLAG_COLUMN)); TEXT_IO.PUT(TO_THIS,EXCLAMATION); end if; if INDENTION > 0 then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(INDENTION)); end if; TEXT_IO.PUT_LINE(TO_THIS,HEADER); exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in PUT_REPORT_LINE(for HEADER)"); raise; end PUT_REPORT_LINE; procedure PUT_REPORT_LINE(INDENTION : in NATURAL; STYLE_ISSUE : in STRING; SUB_HEADING : in STRING; LEAD_IN : in CHARACTER; COUNT : in NATURAL; UNITS : in STRING; ASTERIK_NEEDED : in BOOLEAN := FALSE; EXCLAMATION_NEEDED: in BOOLEAN := FALSE) is COLUMN : POSITIVE; begin if ASTERIK_NEEDED then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(ERROR_FLAG_COLUMN)); TEXT_IO.PUT(TO_THIS,ASTERIK); elsif EXCLAMATION_NEEDED then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(ERROR_FLAG_COLUMN)); TEXT_IO.PUT(TO_THIS,EXCLAMATION); end if; if INDENTION > 0 then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(INDENTION)); end if; TEXT_IO.PUT(TO_THIS,STYLE_ISSUE); if SUB_HEADING /= "" then TEXT_IO.SET_COL(TO_THIS, TEXT_IO.POSITIVE_COUNT(SECOND_COLUMN_START)); TEXT_IO.PUT(TO_THIS,SUB_HEADING); end if; if (COUNT < 10) then COLUMN := DECIMAL_POINT_COLUMN - 2; elsif (COUNT < 100) then COLUMN := DECIMAL_POINT_COLUMN - 3; elsif (COUNT < 1000) then COLUMN := DECIMAL_POINT_COLUMN - 4; else COLUMN := DECIMAL_POINT_COLUMN - 5; end if; TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(COLUMN)); TEXT_IO.PUT(TO_THIS,LEAD_IN); NATURAL_IO.PUT(TO_THIS,COUNT,0); TEXT_IO.SET_COL(TO_THIS, TEXT_IO.POSITIVE_COUNT(THIRD_COLUMN_START)); if (COUNT = 1) and (UNITS /= "") then TEXT_IO.PUT_LINE(TO_THIS,UNITS(1..UNITS'LENGTH - 1)); else TEXT_IO.PUT_LINE(TO_THIS,UNITS); end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in PUT_REPORT_LINE(for INTEGER)"); raise; end PUT_REPORT_LINE; procedure PUT_REPORT_LINE(INDENTION : in NATURAL; STYLE_ISSUE : in STRING; SUB_HEADING : in STRING; LEAD_IN : in CHARACTER; COUNT : in FLOAT; UNITS : in STRING; ASTERIK_NEEDED : in BOOLEAN := FALSE; EXCLAMATION_NEEDED: in BOOLEAN := FALSE) is COLUMN : POSITIVE; begin if ASTERIK_NEEDED then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(ERROR_FLAG_COLUMN)); TEXT_IO.PUT(TO_THIS,ASTERIK); elsif EXCLAMATION_NEEDED then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(ERROR_FLAG_COLUMN)); TEXT_IO.PUT(TO_THIS,EXCLAMATION); end if; if INDENTION > 0 then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(INDENTION)); end if; TEXT_IO.PUT(TO_THIS,STYLE_ISSUE); if SUB_HEADING /= "" then TEXT_IO.SET_COL(TO_THIS, TEXT_IO.POSITIVE_COUNT(SECOND_COLUMN_START)); TEXT_IO.PUT(TO_THIS,SUB_HEADING); end if; TEXT_IO.SET_COL(TO_THIS, TEXT_IO.POSITIVE_COUNT(DECIMAL_POINT_COLUMN - 4)); TEXT_IO.PUT(TO_THIS,LEAD_IN); if UNITS /= PERCENT then -- if COUNT is too small then FLOAT_IO raises CONSTRAINT_ERROR if COUNT < 0.1 then MY_FLOAT_IO.PUT(TO_THIS,0.0,FORE => 3, AFT => 1, EXP => 0); TEXT_IO.SET_COL(TO_THIS, TEXT_IO.POSITIVE_COUNT(THIRD_COLUMN_START)); else MY_FLOAT_IO.PUT(TO_THIS,COUNT,FORE => 3, AFT => 1, EXP => 0); TEXT_IO.SET_COL(TO_THIS, TEXT_IO.POSITIVE_COUNT(THIRD_COLUMN_START)); end if; else -- if COUNT is too small then FLOAT_IO raises CONSTRAINT_ERROR if COUNT < 0.001 then MY_FLOAT_IO.PUT(TO_THIS,0.0,FORE => 3, AFT => 1, EXP => 0); else MY_FLOAT_IO.PUT(TO_THIS,(COUNT*100.0), FORE => 3,AFT => 1,EXP => 0); end if; end if; TEXT_IO.PUT_LINE(TO_THIS,UNITS); exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in PUT_REPORT_LINE(for FLOAT)"); raise; end PUT_REPORT_LINE; procedure PUT_REPORT_LINE(INDENTION : in NATURAL; STYLE_ISSUE : in STRING; SUB_HEADING : in STRING; LOWER_BOUND : in NATURAL; UPPER_BOUND : in NATURAL; UNITS : in STRING; ASTERIK_NEEDED : in BOOLEAN := FALSE; EXCLAMATION_NEEDED: in BOOLEAN := FALSE) is COLUMN : POSITIVE; begin if ASTERIK_NEEDED then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(ERROR_FLAG_COLUMN)); TEXT_IO.PUT(TO_THIS,ASTERIK); elsif EXCLAMATION_NEEDED then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(ERROR_FLAG_COLUMN)); TEXT_IO.PUT(TO_THIS,EXCLAMATION); end if; if INDENTION > 0 then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(INDENTION)); end if; TEXT_IO.PUT(TO_THIS,STYLE_ISSUE); if SUB_HEADING /= "" then TEXT_IO.SET_COL(TO_THIS, TEXT_IO.POSITIVE_COUNT(SECOND_COLUMN_START)); TEXT_IO.PUT(TO_THIS,SUB_HEADING); end if; if (LOWER_BOUND < 10) then COLUMN := DECIMAL_POINT_COLUMN - 1; elsif (LOWER_BOUND < 100) then COLUMN := DECIMAL_POINT_COLUMN - 2; elsif (LOWER_BOUND < 1000) then COLUMN := DECIMAL_POINT_COLUMN - 3; else COLUMN := DECIMAL_POINT_COLUMN - 4; end if; if (UPPER_BOUND < 10) then COLUMN := COLUMN - 1; elsif (UPPER_BOUND < 100) then COLUMN := COLUMN - 2; elsif (UPPER_BOUND < 1000) then COLUMN := COLUMN - 3; else COLUMN := COLUMN - 4; end if; COLUMN := COLUMN - 2; TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(COLUMN)); NATURAL_IO.PUT(TO_THIS,LOWER_BOUND,0); TEXT_IO.PUT(TO_THIS,DOT_DOT); NATURAL_IO.PUT(TO_THIS,UPPER_BOUND,0); TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(THIRD_COLUMN_START)); TEXT_IO.PUT_LINE(TO_THIS,UNITS); exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in PUT_REPORT_LINE(for RANGES)"); raise; end PUT_REPORT_LINE; procedure PUT_REPORT_LINE( KEYWORD_REPORT : in STYLE_PARAMETERS.KEYWORD_USE_DESCRIPT; KEYWORD_COUNT : in NATURAL; KEYWORD_USAGE : in FLOAT; KEYWORD_TYPE : in TOKENIZER.TOKEN_TYPE) is use STYLE_PARAMETERS; package TOKEN_TYPE_IO is new TEXT_IO.ENUMERATION_IO(TOKENIZER.TOKEN_TYPE); TOKEN_STRING : STRING(1..20); UNDERSCORE_COLUMN : NATURAL := 1; begin if (KEYWORD_REPORT.USE_CLASS /= FREE_USE) and (KEYWORD_USAGE > KEYWORD_REPORT.USE_FREQ) then TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(ERROR_FLAG_COLUMN)); TEXT_IO.PUT(TO_THIS,ASTERIK); end if; TEXT_IO.SET_COL(TO_THIS,TEXT_IO.POSITIVE_COUNT(FIRST_COLUMN_START)); TOKEN_TYPE_IO.PUT(TOKEN_STRING,KEYWORD_TYPE); while TOKEN_STRING(UNDERSCORE_COLUMN) /= '_' loop UNDERSCORE_COLUMN := UNDERSCORE_COLUMN + 1; end loop; TEXT_IO.PUT(TO_THIS,TOKEN_STRING(1..UNDERSCORE_COLUMN - 1)); TEXT_IO.SET_COL(TO_THIS,17); if KEYWORD_REPORT.USE_CLASS = NO_USE then TEXT_IO.PUT(TO_THIS," no"); else TEXT_IO.PUT(TO_THIS,"yes"); end if; TEXT_IO.SET_COL(TO_THIS,31); -- if number is too small then FLOAT_IO raises CONSTRAINT_ERROR if KEYWORD_REPORT.USE_FREQ < 0.001 then MY_FLOAT_IO.PUT(TO_THIS,0.0,FORE => 3, AFT => 1, EXP => 0); else MY_FLOAT_IO.PUT(TO_THIS,(KEYWORD_REPORT.USE_FREQ * 100.0), FORE => 3, AFT => 1, EXP => 0); end if; TEXT_IO.PUT(TO_THIS,PERCENT); TEXT_IO.SET_COL(TO_THIS,47); NATURAL_IO.PUT(TO_THIS,KEYWORD_COUNT,3); TEXT_IO.SET_COL(TO_THIS,63); -- if number is too small then FLOAT_IO raises CONSTRAINT_ERROR if KEYWORD_USAGE < 0.001 then MY_FLOAT_IO.PUT(TO_THIS,0.0,FORE => 3, AFT => 1, EXP => 0); else MY_FLOAT_IO.PUT(TO_THIS,(KEYWORD_USAGE * 100.0), FORE => 3, AFT => 1, EXP => 0); end if; TEXT_IO.PUT_LINE(TO_THIS,PERCENT); exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in PUT_REPORT_LINE(for KEYWORDS)"); raise; end PUT_REPORT_LINE; procedure PRINT_LIST ( LIST : in STRING_LIST_TYPE ) is NODE : STRING_LIST_TYPE; begin NODE := LIST; while NODE /= null loop PUT_REPORT_LINE( SECOND_COLUMN_START, DYN.STR(NODE.NAME) ); NODE := NODE.NEXT; end loop; end PRINT_LIST; begin PUT_REPORT_LINE(0,"STYLE Report"); PUT_REPORT_LINE(0,DYN.STR(FILE_NAME)); PUT_REPORT_LINE(0,""); PUT_REPORT_LINE(FIRST_COLUMN_START, "Naming Conventions"); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(FIRST_COLUMN_START, "Invalid Case for an Object Identifier","",' ', FROM_THIS.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER,ERRORS, FROM_THIS.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER /= 0); PUT_REPORT_LINE(FIRST_COLUMN_START,"Invalid Case for a Keyword", "",' ',FROM_THIS.INVALID_CASE_FOR_A_KEYWORD,ERRORS, FROM_THIS.INVALID_CASE_FOR_A_KEYWORD /= 0); if FROM_THIS.ABBREVIATIONS then PUT_REPORT_LINE(FIRST_COLUMN_START,"Too many abbreviations", TRUE,FALSE); end if; PUT_REPORT_LINE(FIRST_COLUMN_START, "Name Segment Size (Separated",DESIRED,LESS_THAN, FROM_THIS.NAME_SEGMENT_SIZE_DESIRED_MAXIMUM,CHARACTERS); PUT_REPORT_LINE(19,"by Underscores)",ACTUAL,' ', FROM_THIS.NAME_SEGMENT_SIZE_ACTUAL,CHARACTERS, FROM_THIS.NAME_SEGMENT_SIZE_ACTUAL > FLOAT(FROM_THIS.NAME_SEGMENT_SIZE_DESIRED_MAXIMUM)); PUT_REPORT_LINE(FIRST_COLUMN_START,"Average Name Size", DESIRED,GREATER_THAN, FROM_THIS.AVERAGE_NAME_SIZE_DESIRED_MINIMUM,CHARACTERS); PUT_REPORT_LINE(0,"",ACTUAL,' ',FROM_THIS.AVERAGE_NAME_SIZE_ACTUAL, CHARACTERS,FROM_THIS.AVERAGE_NAME_SIZE_ACTUAL < FLOAT(FROM_THIS.AVERAGE_NAME_SIZE_DESIRED_MINIMUM)); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(0,""); PUT_REPORT_LINE(FIRST_COLUMN_START,"Physical Layout"); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(FIRST_COLUMN_START, "Occurrences of More Than One Statement/Line","",' ', FROM_THIS.OCCURRENCES_OF_MORE_THAN_ONE_STATEMENT_PER_LINE, ERRORS, FROM_THIS.OCCURRENCES_OF_MORE_THAN_ONE_STATEMENT_PER_LINE > 0); PUT_REPORT_LINE(FIRST_COLUMN_START,"Inconsistant Indentation","",' ', FROM_THIS.INCONSISTANT_INDENTATION,ERRORS, FROM_THIS.INCONSISTANT_INDENTATION > 0); PUT_REPORT_LINE(FIRST_COLUMN_START, "Missing Blank Lines to Set Off a Block","",' ', FROM_THIS.MISSING_BLANK_LINES_TO_SET_OFF_A_BLOCK,ERRORS, FROM_THIS.MISSING_BLANK_LINES_TO_SET_OFF_A_BLOCK > 0); -- Don't look for prologs! -- PUT_REPORT_LINE(FIRST_COLUMN_START, -- "Missing Prolog","",' ',FROM_THIS.MISSING_PROLOG, -- ERRORS,FROM_THIS.MISSING_PROLOG > 0); PUT_REPORT_LINE(FIRST_COLUMN_START,"Loops Without Names","",' ', FROM_THIS.LOOPS_WITHOUT_NAMES,"", FROM_THIS.LOOPS_WITHOUT_NAMES > 0); -- Don't care about blank lines -- PUT_REPORT_LINE(FIRST_COLUMN_START,"Percent of Blank Lines", -- DESIRED,GREATER_THAN, -- FROM_THIS.PERCENT_OF_BLANK_LINES_DESIRED_MINIMUM,PERCENT); -- PUT_REPORT_LINE(0,"",ACTUAL,' ',FROM_THIS.PERCENT_OF_BLANK_LINES_ACTUAL, -- PERCENT,FROM_THIS.PERCENT_OF_BLANK_LINES_ACTUAL < -- FROM_THIS.PERCENT_OF_BLANK_LINES_DESIRED_MINIMUM); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(0,""); PUT_REPORT_LINE(FIRST_COLUMN_START, "Information Hiding, Abstraction, Data Use"); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(FIRST_COLUMN_START, "Percent of Literals In Body ",DESIRED,LESS_THAN, FROM_THIS.PERCENT_OF_LITERALS_IN_BODY_DESIRED_MAXIMUM,PERCENT); PUT_REPORT_LINE(0,"",ACTUAL,' ', FROM_THIS.PERCENT_OF_LITERALS_IN_BODY_ACTUAL,PERCENT, FROM_THIS.PERCENT_OF_LITERALS_IN_BODY_ACTUAL > FROM_THIS.PERCENT_OF_LITERALS_IN_BODY_DESIRED_MAXIMUM); PUT_REPORT_LINE(FIRST_COLUMN_START, "Percent of Universal Types",DESIRED,LESS_THAN, FROM_THIS.PERCENT_OF_UNIVERSAL_TYPES_DESIRED_MAXIMUM,PERCENT); PUT_REPORT_LINE(0,"",ACTUAL,' ', FROM_THIS.PERCENT_OF_UNIVERSAL_TYPES_ACTUAL,PERCENT, FROM_THIS.PERCENT_OF_UNIVERSAL_TYPES_ACTUAL > FROM_THIS.PERCENT_OF_UNIVERSAL_TYPES_DESIRED_MAXIMUM); if FROM_THIS.DATA_STRUCTURING_TYPES_NOT_USED /= (DATA_STRUCTURE_TYPES'FIRST .. DATA_STRUCTURE_TYPES'LAST => FALSE) then PUT_REPORT_LINE(FIRST_COLUMN_START, "Data Structuring Types NOT Used",FALSE,TRUE); for DATA_TYPES in DATA_STRUCTURE_TYPES loop if FROM_THIS.DATA_STRUCTURING_TYPES_NOT_USED(DATA_TYPES) then case DATA_TYPES is when ARRAY_TYPES => PUT_REPORT_LINE(SECOND_COLUMN_START,"Array Types"); when ENUMERATION_TYPES => PUT_REPORT_LINE(SECOND_COLUMN_START, "Enumeration Types"); when RECORD_TYPES => PUT_REPORT_LINE(SECOND_COLUMN_START,"Record Types"); end case; end if; end loop; end if; if not FROM_THIS.ATTRIBUTES_USED then PUT_REPORT_LINE(FIRST_COLUMN_START,"No Attributes are Used", FALSE,TRUE); end if; ADA_SPECIFICS_USED := FROM_THIS.AND_THENS_USED and FROM_THIS.OR_ELSES_USED and FROM_THIS.EXITS_USED and FROM_THIS.XORS_USED and FROM_THIS.ELSIFS_USED and FROM_THIS.EXCEPTIONS_USED and FROM_THIS.INS_USED and FROM_THIS.OUTS_USED and FROM_THIS.IN_OUTS_USED and FROM_THIS.PRIVATES_USED; if NOT ADA_SPECIFICS_USED then PUT_REPORT_LINE( FIRST_COLUMN_START, "Ada-Specific Features NOT used", FALSE, TRUE); if not FROM_THIS.AND_THENS_USED then PUT_REPORT_LINE(SECOND_COLUMN_START,"AND THEN"); end if; if not FROM_THIS.OR_ELSES_USED then PUT_REPORT_LINE(SECOND_COLUMN_START,"OR ELSE"); end if; if not FROM_THIS.EXITS_USED then PUT_REPORT_LINE(SECOND_COLUMN_START,"EXITS"); end if; if not FROM_THIS.XORS_USED then PUT_REPORT_LINE(SECOND_COLUMN_START,"XOR"); end if; if not FROM_THIS.ELSIFS_USED then PUT_REPORT_LINE(SECOND_COLUMN_START,"ELSIF"); end if; if not FROM_THIS.EXCEPTIONS_USED then PUT_REPORT_LINE(SECOND_COLUMN_START,"EXCEPTION"); end if; if not FROM_THIS.INS_USED then PUT_REPORT_LINE(SECOND_COLUMN_START,"IN parameters"); end if; if not FROM_THIS.OUTS_USED then PUT_REPORT_LINE(SECOND_COLUMN_START,"OUT parameters"); end if; if not FROM_THIS.IN_OUTS_USED then PUT_REPORT_LINE(SECOND_COLUMN_START,"IN OUT parameters"); end if; if not FROM_THIS.PRIVATES_USED then PUT_REPORT_LINE(SECOND_COLUMN_START,"PRIVATEs"); end if; end if; PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(0,""); PUT_REPORT_LINE(FIRST_COLUMN_START,"Modularity"); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(FIRST_COLUMN_START,"Average Number of Parameters", "Range",FROM_THIS.AVERAGE_NUMBER_OF_PARAMETERS_DESIRED_MINIMUM, FROM_THIS.AVERAGE_NUMBER_OF_PARAMETERS_DESIRED_MAXIMUM, PARAMETERS); PUT_REPORT_LINE(FIRST_COLUMN_START + 2, "Instances of parameters below minimum","",' ', FROM_THIS.INSTANCES_OF_PARAMETERS_BELOW_MINIMUM,"", FROM_THIS.INSTANCES_OF_PARAMETERS_BELOW_MINIMUM > 0); PUT_REPORT_LINE(FIRST_COLUMN_START + 2, "Instances of parameters above maximum","",' ', FROM_THIS.INSTANCES_OF_PARAMETERS_ABOVE_MAXIMUM,"", FROM_THIS.INSTANCES_OF_PARAMETERS_ABOVE_MAXIMUM > 0); PUT_REPORT_LINE(FIRST_COLUMN_START,"Average Subprogram Size","Range", FROM_THIS.AVERAGE_SUBPROGRAM_SIZE_DESIRED_MINIMUM, FROM_THIS.AVERAGE_SUBPROGRAM_SIZE_DESIRED_MAXIMUM, STATEMENTS); PUT_REPORT_LINE(FIRST_COLUMN_START + 2, "Instances of size below minimum","",' ', FROM_THIS.INSTANCES_OF_SIZE_BELOW_MINIMUM,"", FROM_THIS.INSTANCES_OF_SIZE_BELOW_MINIMUM > 0); PUT_REPORT_LINE(FIRST_COLUMN_START +2, "Instances of size above maximum","",' ', FROM_THIS.INSTANCES_OF_SIZE_ABOVE_MAXIMUM,"", FROM_THIS.INSTANCES_OF_SIZE_ABOVE_MAXIMUM > 0); PUT_REPORT_LINE(FIRST_COLUMN_START, "Loops with too many exit statements","",' ', FROM_THIS.INSTANCES_OF_TOO_MANY_EXITS,INSTANCES, FROM_THIS.INSTANCES_OF_TOO_MANY_EXITS > 0); PUT_REPORT_LINE(FIRST_COLUMN_START,"Control Structure Nesting",MAXIMUM, ' ',FROM_THIS.CONTROL_STRUCTURE_NESTING_DESIRED_MAXIMUM,""); PUT_REPORT_LINE(0,"",EXCEEDED,' ', FROM_THIS.CONTROL_STRUCTURE_NESTING_EXCEEDING_MAXIMUM, INSTANCES, FROM_THIS.CONTROL_STRUCTURE_NESTING_EXCEEDING_MAXIMUM > 0); PUT_REPORT_LINE(FIRST_COLUMN_START,"Package Nesting",MAXIMUM,' ', FROM_THIS.PACKAGE_NESTING_DESIRED_MAXIMUM,""); PUT_REPORT_LINE(0,"",EXCEEDED,' ', FROM_THIS.PACKAGE_NESTING_EXCEEDING_MAXIMUM,INSTANCES, FROM_THIS.PACKAGE_NESTING_EXCEEDING_MAXIMUM > 0); PUT_REPORT_LINE(FIRST_COLUMN_START,"Subprogram Nesting",MAXIMUM,' ', FROM_THIS.SUBPROGRAM_NESTING_DESIRED_MAXIMUM,""); PUT_REPORT_LINE(0,"",EXCEEDED,' ', FROM_THIS.SUBPROGRAM_NESTING_EXCEEDING_MAXIMUM,INSTANCES, FROM_THIS.SUBPROGRAM_NESTING_EXCEEDING_MAXIMUM > 0); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(0,""); PUT_REPORT_LINE(FIRST_COLUMN_START,"Comment Usage"); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(FIRST_COLUMN_START,"Number of Comments","",' ', FROM_THIS.NUMBER_OF_COMMENTS,COMMENTS); PUT_REPORT_LINE(FIRST_COLUMN_START,"Average Comment Size", DESIRED,GREATER_THAN, FROM_THIS.AVERAGE_COMMENT_SIZE_DESIRED_MINIMUM,CHARACTERS); PUT_REPORT_LINE(0,"",ACTUAL,' ',FROM_THIS.AVERAGE_COMMENT_SIZE_ACTUAL, CHARACTERS,FROM_THIS.AVERAGE_COMMENT_SIZE_ACTUAL < FLOAT(FROM_THIS.AVERAGE_COMMENT_SIZE_DESIRED_MINIMUM)); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(0,""); PUT_REPORT_LINE(FIRST_COLUMN_START,"Transportability"); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(FIRST_COLUMN_START, "Number of Lines Exceeding Line Length","",' ', FROM_THIS.NUMBER_OF_LINES_EXCEEDING_LINE_LENGTH,"", FROM_THIS.NUMBER_OF_LINES_EXCEEDING_LINE_LENGTH > 0); for I in CHARACTER'FIRST .. CHARACTER'LAST loop if FROM_THIS.GRAPHIC_CHARACTERS_USED(I) > 0 then case I is when ASCII.NUL => ASCII_IMAGE := "'NUL'"; when ASCII.SOH => ASCII_IMAGE := "'SOH'"; when ASCII.STX => ASCII_IMAGE := "'STX'"; when ASCII.ETX => ASCII_IMAGE := "'ETX'"; when ASCII.EOT => ASCII_IMAGE := "'EOT'"; when ASCII.ENQ => ASCII_IMAGE := "'ENQ'"; when ASCII.ACK => ASCII_IMAGE := "'ACK'"; when ASCII.BEL => ASCII_IMAGE := "'BEL'"; when ASCII.BS => ASCII_IMAGE := "'BS '"; when ASCII.HT => ASCII_IMAGE := "'HT '"; when ASCII.LF => ASCII_IMAGE := "'LF '"; when ASCII.VT => ASCII_IMAGE := "'VT '"; when ASCII.FF => ASCII_IMAGE := "'FF '"; when ASCII.CR => ASCII_IMAGE := "'CR '"; when ASCII.SO => ASCII_IMAGE := "'SO '"; when ASCII.SI => ASCII_IMAGE := "'SI '"; when ASCII.DLE => ASCII_IMAGE := "'DLE'"; when ASCII.DC1 => ASCII_IMAGE := "'DC1'"; when ASCII.DC2 => ASCII_IMAGE := "'DC2'"; when ASCII.DC3 => ASCII_IMAGE := "'DC3'"; when ASCII.DC4 => ASCII_IMAGE := "'DC4'"; when ASCII.NAK => ASCII_IMAGE := "'NAK'"; when ASCII.SYN => ASCII_IMAGE := "'SYN'"; when ASCII.ETB => ASCII_IMAGE := "'ETB'"; when ASCII.CAN => ASCII_IMAGE := "'CAN'"; when ASCII.EM => ASCII_IMAGE := "'EM '"; when ASCII.SUB => ASCII_IMAGE := "'SUB'"; when ASCII.ESC => ASCII_IMAGE := "'ESC'"; when ASCII.FS => ASCII_IMAGE := "'FS '"; when ASCII.GS => ASCII_IMAGE := "'GS '"; when ASCII.RS => ASCII_IMAGE := "'RS '"; when ASCII.US => ASCII_IMAGE := "'US '"; when ASCII.DEL => ASCII_IMAGE := "'DEL'"; when others => ASCII_IMAGE := "' "& I & " '"; end case; PUT_REPORT_LINE(FIRST_COLUMN_START, "Graphic (Non-Basic) Chararacter Used", ASCII_IMAGE,' ', FROM_THIS.GRAPHIC_CHARACTERS_USED(I),"",TRUE); end if; end loop; -- Needs to be fixed later -- PUT_REPORT_LINE(FIRST_COLUMN_START, -- "Graphic (Non-Basic) Characters Used","",' ', -- FROM_THIS.GRAPHIC_CHARACTERS_USED,""); -- Needs to be fixed later -- PUT_REPORT_LINE(FIRST_COLUMN_START, -- "Non-Graphic Characters Used","",' ', -- FROM_THIS.NON_GRAPHIC_CHARACTERS_USED,""); PUT_REPORT_LINE(FIRST_COLUMN_START,"Address Clauses","",' ', FROM_THIS.ADDRESS_CLAUSES,"", FROM_THIS.ADDRESS_CLAUSES > 0); PUT_REPORT_LINE(FIRST_COLUMN_START,"Representation Specifications","", ' ',FROM_THIS.REPRESENTATION_SPECIFICATIONS,"", FROM_THIS.REPRESENTATION_SPECIFICATIONS > 0); PUT_REPORT_LINE(FIRST_COLUMN_START,"PRAGMA'S used:" ); PRINT_LIST(FROM_THIS.PRAGMAS_USED); PUT_REPORT_LINE(FIRST_COLUMN_START,"Non-Standard PRAGMA's Used"); PRINT_LIST(FROM_THIS.NON_STANDARD_PRAGMAS_USED ); PUT_REPORT_LINE(FIRST_COLUMN_START,"Packages/Procedures WITHed" ); PRINT_LIST( FROM_THIS.PACKAGES_PROCEDURES_WITHED ); PUT_REPORT_LINE(0,HEADER_LINE); PUT_REPORT_LINE(0,""); PUT_REPORT_LINE(FIRST_COLUMN_START, "* => Style Flaw ! => Note: Potential for improvement"); PUT_REPORT_LINE(0,""); if STYLE_PARAMETERS.OUTPUT_KEYWORD_LIST /= STYLE_PARAMETERS.NONE then PUT_REPORT_LINE(0,"Keyword Usage"); PUT_REPORT_LINE(0," Used Keyword Allowed " & "Restriction Occurrences Percentage"); PUT_REPORT_LINE(0,HEADER_LINE); -- Figure out how many total keywords were used so we can figure -- percentages for I in TOKENIZER.KEYWORDS loop KEYWORD_COUNT := KEYWORD_COUNT + FROM_THIS.TOKEN_COUNT(I); end loop; for I in TOKENIZER.KEYWORDS loop if KEYWORD_COUNT > 0 then KEYWORD_PERCENTAGES(I) := FLOAT(FROM_THIS.TOKEN_COUNT(I)) / FLOAT(KEYWORD_COUNT); else KEYWORD_PERCENTAGES(I) := 0.0; end if; case STYLE_PARAMETERS.OUTPUT_KEYWORD_LIST is when STYLE_PARAMETERS.ALL_KEYS => PUT_REPORT_LINE(FROM_THIS.KEYWORD_USAGE(I), FROM_THIS.TOKEN_COUNT(I),KEYWORD_PERCENTAGES(I),I); when STYLE_PARAMETERS.USED => if FROM_THIS.TOKEN_COUNT(I) > 0 then PUT_REPORT_LINE(FROM_THIS.KEYWORD_USAGE(I), FROM_THIS.TOKEN_COUNT(I),KEYWORD_PERCENTAGES(I), I); end if; when STYLE_PARAMETERS.NOT_USED => if FROM_THIS.TOKEN_COUNT(I) = 0 then PUT_REPORT_LINE(FROM_THIS.KEYWORD_USAGE(I), FROM_THIS.TOKEN_COUNT(I),KEYWORD_PERCENTAGES(I), I); end if; when STYLE_PARAMETERS.ERRORS => if (FROM_THIS.KEYWORD_USAGE(I).USE_CLASS /= FREE_USE) and (KEYWORD_PERCENTAGES(I) > FROM_THIS.KEYWORD_USAGE(I).USE_FREQ) then PUT_REPORT_LINE(FROM_THIS.KEYWORD_USAGE(I), FROM_THIS.TOKEN_COUNT(I),KEYWORD_PERCENTAGES(I), I); end if; when STYLE_PARAMETERS.NONE => null; end case; end loop; PUT_REPORT_LINE(0,HEADER_LINE); end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in GENERATE_REPORT"); raise; end GENERATE_REPORT; procedure INSERT_INTO_LIST ( LIST : in out STRING_LIST_TYPE; ELEMENT : DYN.DYN_STRING ) is -- Insert the element name into the list. -- Algorithm: search the list. If the element is not there, -- insert it at the end. LOOKAHEAD : STRING_LIST_TYPE; NEW_NODE : STRING_LIST_TYPE; begin if LIST = null then -- Empty list, insert at beginning NEW_NODE := new STRING_NODE; NEW_NODE.NAME := DYN.D_STRING( DYN.UPPER_CASE( ELEMENT ) ); LIST := NEW_NODE; return; else LOOKAHEAD := LIST; end if; -- Now search the list while LOOKAHEAD.NEXT /= null and DYN.STR(LOOKAHEAD.NAME) /= DYN.UPPER_CASE( ELEMENT ) loop LOOKAHEAD := LOOKAHEAD.NEXT; end loop; if LOOKAHEAD.NEXT = null then NEW_NODE := new STRING_NODE; NEW_NODE.NAME := DYN.D_STRING( DYN.UPPER_CASE( ELEMENT ) ); LOOKAHEAD.NEXT := NEW_NODE; end if; return; end INSERT_INTO_LIST; end REPORT_GENERATOR; :::::::::: stylechec.ada :::::::::: with TOKENIZER; with STYLE_PARAMETERS; with REPORT_GENERATOR; with DYN; with HELP; with DICTIONARY_MANAGER; with CURRENT_EXCEPTION; with TEXT_IO; with FILE_HANDLING; with STACK_PACKAGE; procedure STYLE_CHECKER is -------------------------------------------------------------------------- -- Abstract : This is the main procedure of the Style_Checker. It -- contains types and global variables used by all the -- style checker routines. -------------------------------------------------------------------------- type UNIVERSAL_DATA_TYPE is (INTEGER, SHORT_INTEGER, LONG_INTEGER, FLOAT, SHORT_FLOAT, LONG_FLOAT, NATURAL, POSITIVE); type STATUS_RECORD is record CURRENT_TOKEN : TOKENIZER.TOKEN; CURRENT_INDENT : NATURAL := 0; CURRENT_TRAIL_COMMENT_INDENT : NATURAL := 0; CURRENT_STATEMENTS : NATURAL := 0; CURRENT_LINE : NATURAL := 0; EXITS_IN_LOOPS : NATURAL := 0; TOTAL_LINES : NATURAL := 0; TOTAL_BLANK_LINES : NATURAL := 0; IN_BODY : BOOLEAN := FALSE; -- As opposed to being in declarations IN_GENERIC :BOOLEAN := FALSE; PACKAGE_NEST_LEVEL : TOKENIZER.LINE_INDEX_RANGE; CONTROL_NEST_LEVEL : TOKENIZER.LINE_INDEX_RANGE; PROCEDURE_NEST_LEVEL : TOKENIZER.LINE_INDEX_RANGE; BEGIN_INDENT : BOOLEAN := true; SUBPROGRAM_NESTING_INFORMATION : REPORT_GENERATOR.AVERAGE_KEEPING_RECORD; BLANK_LINES_INFORMATION : REPORT_GENERATOR.AVERAGE_KEEPING_RECORD; COMMENT_INFORMATION : REPORT_GENERATOR.AVERAGE_KEEPING_RECORD; LITERAL_INFORMATION : REPORT_GENERATOR.AVERAGE_KEEPING_RECORD; UNIVERSAL_INFORMATION : REPORT_GENERATOR.AVERAGE_KEEPING_RECORD; IDENTIFIERS_INFORMATION : REPORT_GENERATOR.AVERAGE_KEEPING_RECORD; -- case of names and reserve words CASE_OF_RESERVED_WORDS : STYLE_PARAMETERS.RESERVE_WORD_CASES := STYLE_PARAMETERS.CASE_OF_RESERVED_WORDS; CASE_OF_OBJECT_NAMES : STYLE_PARAMETERS.OBJECT_NAME_CASES := STYLE_PARAMETERS.CASE_OF_OBJECT_NAMES; end record; type USAGE_RECORD is record ATTRIBUTES : boolean := false; DATA_STR_ARRAY : boolean := false; DATA_STR_ENUMERATION : boolean := false; DATA_STR_RECORD : boolean := false; REPRESENTATION_SPECIFICATIONS : boolean := false; ADDRESS_CLAUSES : boolean := false; end record; -- Variables STYLE_REPORT : REPORT_GENERATOR.REPORT_RECORD; -- Miscellaneous mistake records ABBREVIATIONS : NATURAL := 0; CONTROL_STRUCTURES_WITHOUT_LEADING_WHITE_SPACE : NATURAL := 0; COULD_HAVE_USED_AN_ELSIF : NATURAL := 0; DEEPEST_IF_NESTING : NATURAL := 0; DEEPEST_PACKAGE_NESTING : NATURAL := 0; DEEPEST_PROCEDURE_NESTING : NATURAL := 0; INDENTATION_ERRORS : NATURAL := 0; LONG_LOOPS_WITHOUT_LOOP_NAMES : NATURAL := 0; MISSING_UNDERSCORES : NATURAL := 0; MORE_THAN_ONE_STATEMENT_PER_LINE : NATURAL := 0; OBJECT_NAME_CAPITALIZATION_MISTAKES : array(STYLE_PARAMETERS.OBJECT_NAME_CASES) of NATURAL := (STYLE_PARAMETERS.OBJECT_NAME_CASES'FIRST .. STYLE_PARAMETERS.OBJECT_NAME_CASES'LAST => 0); RESERVE_WORD_CAPITALIZATION_MISTAKES : array(STYLE_PARAMETERS.RESERVE_WORD_CASES) of NATURAL := (STYLE_PARAMETERS.RESERVE_WORD_CASES'FIRST .. STYLE_PARAMETERS.RESERVE_WORD_CASES'LAST => 0); -- Stack MAX_NESTING : constant positive := TOKENIZER.LINE_INDEX_RANGE'LAST; type NEST_TYPE is (HEADER, PACKAGE_NEST, SUBPROGRAM_NEST, CONTROL_NEST); type NESTING_RECORD is record LEVEL : natural range 0..MAX_NESTING; INDENT : TOKENIZER.LINE_INDEX_RANGE; STATEMENTS : natural := 0; EXITS : natural := 0; IN_BODY : BOOLEAN := FALSE; KIND_OF_NEST : NEST_TYPE; START_TOKEN : TOKENIZER.TOKEN; PARAMETERS : natural := 0; -- IN_PARAMS : natural := 0; -- OUT_PARAMS : natural := 0; -- IN_OUT_PARAMS : natural := 0; end record; STACK_LIMIT : positive := MAX_NESTING; package NEST_STACK is new STACK_PACKAGE( ELEMENTS => NESTING_RECORD, SIZE => STACK_LIMIT ); -- The stack itself MISC_NEST_STACK : NEST_STACK.HELP_INFO_STACK; -- Dictionary pointer STYLE_DICTIONARY : DICTIONARY_MANAGER.DICTIONARY_PTR; -- Files FLAWS_FILE : TEXT_IO.FILE_TYPE; STYLE_FILE : TEXT_IO.FILE_TYPE; FILE_NAME : DYN.DYN_STRING := DYN.D_STRING(" "); -- General purpose current status global variable CURRENT_STATUS : STATUS_RECORD; CURRENT_USAGE : USAGE_RECORD; -- functions function CURRENT_TOKEN return TOKENIZER.TOKEN; function PREVIOUS_NON_TRIVIAL_TOKEN(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) return TOKENIZER.TOKEN; function NEXT_NON_TRIVIAL_TOKEN(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) return TOKENIZER.TOKEN; function GET_NEXT_TOKEN_AND_UPDATE_COUNT return TOKENIZER.TOKEN; function IS_STATEMENT(EXAMINED_TOKEN : in TOKENIZER.TOKEN) return boolean; procedure NEW_LINE_TOKEN_ENCOUNTERED(FROM_THIS_TOKEN : in TOKENIZER.TOKEN); function SEARCH_FORWARD ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN; function SEARCH_FORWARD_FOR_ONE_OF ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE1 : TOKENIZER.TOKEN_TYPE; GOAL_TYPE2 : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN; -- Moving this to ENTERING_BLOCK -- function SEARCH_FORWARD_FOR_ONE_OF ( START_TOKEN : TOKENIZER.TOKEN; -- GOAL_TYPE1 : TOKENIZER.TOKEN_TYPE; -- GOAL_TYPE2 : TOKENIZER.TOKEN_TYPE; -- GOAL_TYPE3 : TOKENIZER.TOKEN_TYPE ) -- return TOKENIZER.TOKEN; function SEARCH_BACKWARD ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN; function SEARCH_BACKWARD_FOR_ONE_OF ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE1 : TOKENIZER.TOKEN_TYPE; GOAL_TYPE2 : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN; procedure BEGIN_OF_LINE_INDENTATION( CURRENT_TOKEN : TOKENIZER.TOKEN); procedure LITERAL_ENCOUNTERED(FROM_THIS_TOKEN : in TOKENIZER.TOKEN); procedure COMMENT_TOKEN_ENCOUNTERED(FROM_THIS_TOKEN : in TOKENIZER.TOKEN); procedure RESERVE_WORD_ENCOUNTERED(RESERVE_WORD_TOKEN : in TOKENIZER.TOKEN); procedure OBJECT_NAME_ENCOUNTERED(OBJECT_NAME_TOKEN : in TOKENIZER.TOKEN); procedure ENTERING_BLOCK_STRUCTURE(FROM_THIS_TOKEN : in TOKENIZER.TOKEN); procedure ENTERING_SUB_BLOCK_STRUCTURE(FROM_THIS_TOKEN: in TOKENIZER.TOKEN); procedure EXITING_BLOCK_STRUCTURE(FROM_THIS_TOKEN : in TOKENIZER.TOKEN); procedure TYPE_DECLARATION(FROM_THIS_TOKEN : in TOKENIZER.TOKEN); procedure CHECK_THE_STYLE; procedure CHECK_END_OF_BLOCKS; procedure CHECK_STATEMENTS_PER_LINE(FROM_THIS_TOKEN : in TOKENIZER.TOKEN); function CURRENT_TOKEN return TOKENIZER.TOKEN is separate; function PREVIOUS_NON_TRIVIAL_TOKEN(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) return TOKENIZER.TOKEN is separate; function NEXT_NON_TRIVIAL_TOKEN(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) return TOKENIZER.TOKEN is separate; function GET_NEXT_TOKEN_AND_UPDATE_COUNT return TOKENIZER.TOKEN is separate; function IS_STATEMENT(EXAMINED_TOKEN : in TOKENIZER.TOKEN) return boolean is separate; function SEARCH_FORWARD ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN is separate; function SEARCH_FORWARD_FOR_ONE_OF ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE1 : TOKENIZER.TOKEN_TYPE; GOAL_TYPE2 : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN is separate; -- function SEARCH_FORWARD_FOR_ONE_OF ( START_TOKEN : TOKENIZER.TOKEN; -- GOAL_TYPE1 : TOKENIZER.TOKEN_TYPE; -- GOAL_TYPE2 : TOKENIZER.TOKEN_TYPE; -- GOAL_TYPE3 : TOKENIZER.TOKEN_TYPE ) -- return TOKENIZER.TOKEN is separate; -- function SEARCH_BACKWARD ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN is separate; function SEARCH_BACKWARD_FOR_ONE_OF ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE1 : TOKENIZER.TOKEN_TYPE; GOAL_TYPE2 : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN is separate; procedure NEW_LINE_TOKEN_ENCOUNTERED(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is separate; procedure BEGIN_OF_LINE_INDENTATION( CURRENT_TOKEN : TOKENIZER.TOKEN) is separate; procedure LITERAL_ENCOUNTERED(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is separate; procedure COMMENT_TOKEN_ENCOUNTERED(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is separate; procedure RESERVE_WORD_ENCOUNTERED(RESERVE_WORD_TOKEN : in TOKENIZER.TOKEN) is separate; procedure OBJECT_NAME_ENCOUNTERED(OBJECT_NAME_TOKEN : in TOKENIZER.TOKEN) is separate; procedure ENTERING_BLOCK_STRUCTURE(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is separate; procedure ENTERING_SUB_BLOCK_STRUCTURE(FROM_THIS_TOKEN: in TOKENIZER.TOKEN) is separate; procedure EXITING_BLOCK_STRUCTURE(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is separate; procedure TYPE_DECLARATION(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is separate; procedure CHECK_THE_STYLE is separate; procedure CHECK_END_OF_BLOCKS is separate; procedure CHECK_STATEMENTS_PER_LINE(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is separate; begin -- Style_Checker TOKENIZER.BUILD_TOKENS; FILE_HANDLING.OUTPUT_FILE_ID(FLAWS_FILE,STYLE_FILE); DICTIONARY_MANAGER.CREATE_DICTIONARY( DICTIONARY_KIND => DICTIONARY_MANAGER.MASTER, DICTIONARY_IN => STYLE_DICTIONARY, FILENAME => FILE_HANDLING.STYLE_DICTIONARY_NAME ); CHECK_THE_STYLE; REPORT_GENERATOR.GENERATE_REPORT(STYLE_REPORT,STYLE_FILE,FILE_NAME); TEXT_IO.CLOSE(FLAWS_FILE); TEXT_IO.CLOSE(STYLE_FILE); exception when FILE_HANDLING.HELP_ASKED_FOR => begin -- exceptions can be raised here! -- call help file FILE_HANDLING.HELP_FILE_NAME HELP.HELP_SCREEN( HELP.HELP, FILE_HANDLING.HELP_FILE_NAME); exception when HELP.HELP_OPEN_ERROR => TEXT_IO.PUT_LINE("Cannot Open the HELP File!"); when HELP.HELP_FILE_ERROR => TEXT_IO.PUT_LINE("Cannot find the HELP File!"); when HELP.HELP_FORMAT_ERROR => TEXT_IO.PUT_LINE( "The HELP file is in the wrong format!"); end; when others => TEXT_IO.PUT("In STYLE_CHECKER main body: exception --"); TEXT_IO.PUT_LINE(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("Attempting to generate a partial Style Report"); REPORT_GENERATOR.GENERATE_REPORT(STYLE_REPORT, STYLE_FILE,FILE_NAME); TEXT_IO.CLOSE(FLAWS_FILE); TEXT_IO.CLOSE(STYLE_FILE); raise; end STYLE_CHECKER; pragma MAIN; :::::::::: beginofli.ada :::::::::: separate( STYLE_CHECKER ) procedure BEGIN_OF_LINE_INDENTATION ( CURRENT_TOKEN : TOKENIZER.TOKEN) is -- -- PARAMETERS: -- This is passed a token which should be at the start of -- a line. -- ABSTRACT: This checks the indentation of the token. -- ALGORITHM -- Cases: -- -- Comments. There are too many radically different commenting -- styles. Comments are ignored for indentation. (Note trailing -- comments.) -- Outdent for: << labels >> -- Indent for: Statements, and { -- else -- when -- elsif -- begin -- record -- declare -- generic -- limited -- private -- "<<"} -- left label brackett; -- -- Otherwise: Consider as the continuation of a statement. In this case, -- indentation should be greater than the 'normal'. -- -- Determining indentation level. -- The 'entering-block-structure' and 'leaving ...' sets flags about current -- indentation levels. -- If this is the first element after a block enter, -- a flag will be set to indicate further indnetation is necessary. -- If a comment - this is allowed to stay at the same level of indentation, -- or be indented. -- The first line is checked to see indentation is more than the outer block -- level. This sets the indentation level for the block. The flags are -- reset. -- If this is a further line in the block, the indentation should match -- what was there before. -- use TOKENIZER; LOOKAHEAD : TOKENIZER.TOKEN; LINE : TOKENIZER.LINE_NUM_RANGE; COLUMN : TOKENIZER.LINE_INDEX_RANGE; SOURCE_LINE : DYN.DYN_STRING; -- Error messages LABEL_NOT_OUTDENTED : constant string := "This Label should be outdented further!"; LOOP_NOT_OUTDENTED : constant string := "This Loop-name should be outdented further!"; CONTINUATION_NOT_INDENTED : constant string := "The statement-continuation in this line should be indented!"; LINE_NOT_INDENTED : constant string := "This line is not indented Properly!"; LINE_SHOULD_BE_INDENTED : constant string := "This line should be indented to column: "; LINE_TOO_LITTLE_INDENTED : constant string := "This line is not indented enough!"; BEGIN_NOT_INDENTED : constant string := "Beginning of this block not indented properly. Line ignored for Indentation!"; function OTHER_INDENT_CASES( A_TOKEN : in TOKENIZER.TOKEN ) return boolean is begin case TOKENIZER.TYPE_OF_TOKEN_IS( A_TOKEN ) is when TOKENIZER.ELSE_TOKEN => return true; when TOKENIZER.WHEN_TOKEN => return true; when TOKENIZER.BEGIN_TOKEN => return true; when TOKENIZER.ELSIF_TOKEN => return true; when TOKENIZER.DECLARE_TOKEN => return true; -- Is this correct? when TOKENIZER.GENERIC_TOKEN => return true; when TOKENIZER.LIMITED_TOKEN => return true; when TOKENIZER.PRIVATE_TOKEN => return true; when others => return false; end case; end OTHER_INDENT_CASES; function IS_LOOP_NAME( NAME_TOKEN : TOKENIZER.TOKEN ) return boolean is -- checks to find "IDENTIFIER :" which is a loop name LOOKAHEAD : TOKENIZER.TOKEN; LOOK2 : TOKENIZER.TOKEN; begin LOOKAHEAD := NEXT_NON_TRIVIAL_TOKEN( NAME_TOKEN ); LOOK2 := NEXT_NON_TRIVIAL_TOKEN( LOOKAHEAD ); return TOKENIZER.TYPE_OF_TOKEN_IS( NAME_TOKEN) = TOKENIZER.IDENTIFIER and TOKENIZER.TYPE_OF_TOKEN_IS( LOOKAHEAD ) = TOKENIZER.COLON and (TOKENIZER.TYPE_OF_TOKEN_IS( LOOK2 ) = TOKENIZER.FOR_TOKEN or TOKENIZER.TYPE_OF_TOKEN_IS( LOOK2 ) = TOKENIZER.WHILE_TOKEN or TOKENIZER.TYPE_OF_TOKEN_IS( LOOK2 ) = TOKENIZER.LOOP_TOKEN); exception when END_OF_TOKENS => return false; -- at least let this continue! when others => raise; end IS_LOOP_NAME; function LOOP_CONTINUATION( LOOP_TOKEN : TOKENIZER.TOKEN ) return boolean is -- ABSTRACT : Determine whether this is the LOOP token of a WHILE. . .LOOP -- statement. -- PARAMETER: LOOP_TOKEN is a token which is matched against the LOOP -- part of the WHILE... LOOP template LOOKAHEAD : TOKENIZER.TOKEN; LOOKAHEAD_TYPE : TOKENIZER.TOKEN_TYPE; begin if TOKENIZER.TYPE_OF_TOKEN_IS(LOOP_TOKEN)=TOKENIZER.LOOP_TOKEN then -- look for a "FOR" or "WHILE" LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN( LOOP_TOKEN ); while not IS_STATEMENT(LOOKAHEAD) loop LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN( LOOKAHEAD ); end loop; LOOKAHEAD_TYPE := TOKENIZER.TYPE_OF_TOKEN_IS( LOOKAHEAD ); if (LOOKAHEAD_TYPE = TOKENIZER.WHILE_TOKEN or LOOKAHEAD_TYPE = TOKENIZER.FOR_TOKEN) then -- this is the continuation of a while...loop statement! return TRUE; else return FALSE; end if; else return FALSE; end if; end LOOP_CONTINUATION; begin -- check whether this is declarations and if those are required to be indented if CURRENT_STATUS.IN_BODY or STYLE_PARAMETERS.IS_DECLARATION_INDENTATION_REQUIRED then -- Position of Token TOKENIZER.TOKEN_POSITION( CURRENT_TOKEN, LINE, COLUMN ); -- Determine indentation case if TOKENIZER.TYPE_OF_TOKEN_IS( CURRENT_TOKEN ) = LEFT_LABEL_BRACKET then -- Label - outdent!? if COLUMN >= CURRENT_STATUS.CURRENT_INDENT then -- Error! should be outdented! if not CURRENT_STATUS.BEGIN_INDENT then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, CURRENT_TOKEN, LABEL_NOT_OUTDENTED, REPORT_GENERATOR.INCONSISTANT_INDENTATION); STYLE_REPORT.INCONSISTANT_INDENTATION:= STYLE_REPORT.INCONSISTANT_INDENTATION + 1; -- else -- Hard to check for label indentation at the beginning of a block end if; end if; elsif IS_LOOP_NAME( CURRENT_TOKEN ) then if COLUMN > CURRENT_STATUS.CURRENT_INDENT or else (COLUMN = CURRENT_STATUS.CURRENT_INDENT and not CURRENT_STATUS.BEGIN_INDENT) then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, CURRENT_TOKEN, LOOP_NOT_OUTDENTED, REPORT_GENERATOR.INCONSISTANT_INDENTATION); STYLE_REPORT.INCONSISTANT_INDENTATION:= STYLE_REPORT.INCONSISTANT_INDENTATION + 1; end if; elsif (IS_STATEMENT(CURRENT_TOKEN) and not LOOP_CONTINUATION(CURRENT_TOKEN)) or OTHER_INDENT_CASES(CURRENT_TOKEN) then -- Normal Statements! if CURRENT_STATUS.BEGIN_INDENT then -- This case is the beginning of an indented block if COLUMN > CURRENT_STATUS.CURRENT_INDENT then -- update the indentation count (beginning of block) CURRENT_STATUS.BEGIN_INDENT := false; -- This line established the indentation for the block! CURRENT_STATUS.CURRENT_INDENT := COLUMN; else case TOKENIZER.TYPE_OF_TOKEN_IS( CURRENT_TOKEN ) is when TOKENIZER.ELSE_TOKEN | TOKENIZER.ELSIF_TOKEN | TOKENIZER.WHEN_TOKEN | TOKENIZER.BEGIN_TOKEN | TOKENIZER.PRIVATE_TOKEN | TOKENIZER.LIMITED_TOKEN | TOKENIZER.GENERIC_TOKEN | TOKENIZER.END_TOKEN | TOKENIZER.EXCEPTION_TOKEN => -- actually these should be indented to the -- last level of indentation to be precise! if COLUMN < CURRENT_STATUS.CURRENT_INDENT then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, CURRENT_TOKEN, BEGIN_NOT_INDENTED, REPORT_GENERATOR.INCONSISTANT_INDENTATION); STYLE_REPORT.INCONSISTANT_INDENTATION:= STYLE_REPORT.INCONSISTANT_INDENTATION + 1; end if; when TOKENIZER.COMMENT => null; when others => REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, CURRENT_TOKEN, BEGIN_NOT_INDENTED, REPORT_GENERATOR.INCONSISTANT_INDENTATION); STYLE_REPORT.INCONSISTANT_INDENTATION:= STYLE_REPORT.INCONSISTANT_INDENTATION + 1; end case; end if; else -- Indentation normal if COLUMN > CURRENT_STATUS.CURRENT_INDENT then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, CURRENT_TOKEN, LINE_SHOULD_BE_INDENTED & INTEGER'IMAGE(CURRENT_STATUS.CURRENT_INDENT), REPORT_GENERATOR.INCONSISTANT_INDENTATION); STYLE_REPORT.INCONSISTANT_INDENTATION:= STYLE_REPORT.INCONSISTANT_INDENTATION + 1; elsif COLUMN < CURRENT_STATUS.CURRENT_INDENT then case TOKENIZER.TYPE_OF_TOKEN_IS( CURRENT_TOKEN ) is when TOKENIZER.ELSE_TOKEN | TOKENIZER.ELSIF_TOKEN | TOKENIZER.WHEN_TOKEN | TOKENIZER.BEGIN_TOKEN | TOKENIZER.PRIVATE_TOKEN | TOKENIZER.LIMITED_TOKEN | TOKENIZER.GENERIC_TOKEN | TOKENIZER.END_TOKEN | TOKENIZER.EXCEPTION_TOKEN => -- actually these should be indented to the -- last level of indentation to be precise! null; -- these are o.k. when TOKENIZER.IDENTIFIER => -- check for loop names! LOOKAHEAD := NEXT_NON_TRIVIAL_TOKEN( CURRENT_TOKEN ); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD)/=TOKENIZER.COLON then -- Not a loop name and should be indented! REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, CURRENT_TOKEN, LINE_TOO_LITTLE_INDENTED, REPORT_GENERATOR.INCONSISTANT_INDENTATION); STYLE_REPORT.INCONSISTANT_INDENTATION:= STYLE_REPORT.INCONSISTANT_INDENTATION + 1; end if; when TOKENIZER.FUNCTION_TOKEN | TOKENIZER.PROCEDURE_TOKEN | TOKENIZER.PACKAGE_TOKEN => if CURRENT_STATUS.IN_GENERIC then null; -- spec should be outdented to generic level else REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, CURRENT_TOKEN, LINE_TOO_LITTLE_INDENTED, REPORT_GENERATOR.INCONSISTANT_INDENTATION); STYLE_REPORT.INCONSISTANT_INDENTATION:= STYLE_REPORT.INCONSISTANT_INDENTATION + 1; end if; when others => REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, CURRENT_TOKEN, LINE_TOO_LITTLE_INDENTED, REPORT_GENERATOR.INCONSISTANT_INDENTATION); STYLE_REPORT.INCONSISTANT_INDENTATION:= STYLE_REPORT.INCONSISTANT_INDENTATION + 1; end case; end if; end if; elsif TOKENIZER.TYPE_OF_TOKEN_IS( CURRENT_TOKEN ) = COMMENT then -- COMMENTS are ignored for indentation null; else -- Statement continuation - should be indented more than norm. -- UNLESS! this is a blank line! if TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= TOKENIZER.END_OF_LINE and TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= TOKENIZER.END_OF_FILE then if COLUMN <= CURRENT_STATUS.CURRENT_INDENT then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, CURRENT_TOKEN, CONTINUATION_NOT_INDENTED, REPORT_GENERATOR.INCONSISTANT_INDENTATION); STYLE_REPORT.INCONSISTANT_INDENTATION:= STYLE_REPORT.INCONSISTANT_INDENTATION + 1; end if; end if; end if; end if; -- if in declaration and no indentation checking required! exception when others => TEXT_IO.NEW_LINE; TEXT_IO.PUT("Inside BEGIN_OF_LINE_INDENTATION -- exception: " ); TEXT_IO.PUT_LINE(CURRENT_EXCEPTION.NAME ); TEXT_IO.PUT("While in line:"); TOKENIZER.LINE_CONTAINING_TOKEN(CURRENT_TOKEN,SOURCE_LINE ); TEXT_IO.PUT_LINE( DYN.STR( SOURCE_LINE ) ); end BEGIN_OF_LINE_INDENTATION; :::::::::: checkstat.ada :::::::::: separate( STYLE_CHECKER ) procedure CHECK_STATEMENTS_PER_LINE(FROM_THIS_TOKEN : in TOKENIZER.TOKEN ) is -- ABSTRACT: This procedure checks to see if there are multiple statements -- in this line. -- -- Parameter: FROM_THIS_TOKEN is a token which should be the first token -- on the line. -- Algorithm: Every time a statement is encountered, we increment the -- Current_statements counter. Past the first token, a -- statement sets the multiple-statements-per-line flag -- UNLESS it is the following cases. -- for . . . loop (loop ok) -- while. . .loop (loop ok) -- when. . => statement (is o.k.) -- Finally, if multiple statements encountered, PUT_FLAW. -- -- It was decided that the following case WAS ILLEGAL! -- This has been commented out! -- with X; use X; (use allowed) use TOKENIZER; MULTI_STATEMENT_FLAG : boolean; LOOKAHEAD : TOKENIZER.TOKEN; FIRST_TYPE : TOKENIZER.TOKEN_TYPE; LOOKAHEAD_TYPE : TOKENIZER.TOKEN_TYPE; STATEMENTS_ON_LINE : natural := 0; MULTI_STMN_MSG : constant string := "There are more than one statements on this line!"; begin if IS_STATEMENT( FROM_THIS_TOKEN ) then STATEMENTS_ON_LINE := 1; else STATEMENTS_ON_LINE := 0; end if; FIRST_TYPE := TOKENIZER.TYPE_OF_TOKEN_IS( FROM_THIS_TOKEN ); LOOKAHEAD := TOKENIZER.NEXT_TOKEN( FROM_THIS_TOKEN ); MULTI_STATEMENT_FLAG := false; while TOKENIZER.TYPE_OF_TOKEN_IS( LOOKAHEAD ) /= TOKENIZER.END_OF_LINE and TOKENIZER.TYPE_OF_TOKEN_IS( LOOKAHEAD ) /= TOKENIZER.END_OF_FILE loop if IS_STATEMENT( LOOKAHEAD ) then STATEMENTS_ON_LINE := STATEMENTS_ON_LINE + 1; case TOKENIZER.TYPE_OF_TOKEN_IS( LOOKAHEAD ) is when TOKENIZER.LOOP_TOKEN => -- Good examples: -- for ... loop -- for ... -- ... loop -- Bad -- x := (y+z)* -- p; loop if STATEMENTS_ON_LINE > 2 then MULTI_STATEMENT_FLAG := true; elsif IS_STATEMENT (FROM_THIS_TOKEN) then if (FIRST_TYPE /= TOKENIZER.WHILE_TOKEN and FIRST_TYPE /= TOKENIZER.FOR_TOKEN) then MULTI_STATEMENT_FLAG := true; end if; else -- look for a "FOR" or "WHILE" LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN( FROM_THIS_TOKEN ); while not IS_STATEMENT(LOOKAHEAD) loop LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN( LOOKAHEAD ); end loop; LOOKAHEAD_TYPE := TOKENIZER.TYPE_OF_TOKEN_IS( LOOKAHEAD ); if (LOOKAHEAD_TYPE /= TOKENIZER.WHILE_TOKEN and LOOKAHEAD_TYPE /= TOKENIZER.FOR_TOKEN) then MULTI_STATEMENT_FLAG := true; end if; end if; when others => if FIRST_TYPE = TOKENIZER.WHEN_TOKEN and STATEMENTS_ON_LINE <2 then null; -- this is ok! else MULTI_STATEMENT_FLAG := true; end if; end case; end if; LOOKAHEAD := TOKENIZER.NEXT_TOKEN( LOOKAHEAD ); end loop; if MULTI_STATEMENT_FLAG then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, FROM_THIS_TOKEN, MULTI_STMN_MSG, REPORT_GENERATOR.MORE_THAN_ONE_STATEMENT_ON_LINE); STYLE_REPORT.OCCURRENCES_OF_MORE_THAN_ONE_STATEMENT_PER_LINE := STYLE_REPORT.OCCURRENCES_OF_MORE_THAN_ONE_STATEMENT_PER_LINE + 1; end if; null; exception when END_OF_TOKENS => null; -- This should be o.k. END-OF-TOKENS will be handled elsewhere! -- TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); -- TEXT_IO.PUT_LINE(" in CHECK_STATEMENTS_PER_LINE"); when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in CHECK_STATEMENTS_PER_LINE"); raise; end CHECK_STATEMENTS_PER_LINE; :::::::::: checkendo.ada :::::::::: separate (STYLE_CHECKER) procedure CHECK_END_OF_BLOCKS is -- ABSTRACT: This checks to see if there are any extraneous -- nesting elements left on the stack at the end of input. -- If so it put out an error in the flaws file. OLD_NEST_REC : NESTING_RECORD; UNMATCHED_NEST_MSG : constant string := "There are not enough 'ends' to close all the blocks at the end of input!"; begin NEST_STACK.POP( OLD_NEST_REC, MISC_NEST_STACK ); while OLD_NEST_REC.KIND_OF_NEST /= HEADER loop -- unmatched nesting elements! REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, OLD_NEST_REC.START_TOKEN, UNMATCHED_NEST_MSG, REPORT_GENERATOR.UNMATCHED_NESTING); NEST_STACK.POP( OLD_NEST_REC, MISC_NEST_STACK ); end loop; -- restore the header record, just to make sure? NEST_STACK.PUSH( OLD_NEST_REC, MISC_NEST_STACK ); null; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in CHECK_END_OF_BLOCKS"); raise; end CHECK_END_OF_BLOCKS; :::::::::: checkthes.ada :::::::::: separate (STYLE_CHECKER) procedure CHECK_THE_STYLE is -------------------------------------------------------------------------- -- Abstract : This procedure contains the main loop for the Style_Checker -------------------------------------------------------------------------- -- Algorithm : General algorithm is : -- Perform necessary initialization of global variables -- Get first token -- Go through all tokens in order, calling routines -- to handle each particular type of token -- Final clean up and name length checking -------------------------------------------------------------------------- use TOKENIZER; CURRENT_TOKEN : TOKENIZER.TOKEN; LOOK_AHEAD_TOKEN : TOKENIZER.TOKEN; NEST_HEADER : NESTING_RECORD; SOURCE_LINE : DYN.DYN_STRING; CH : CHARACTER; FINAL_MSG : constant STRING := "Finish checking started in above statement. Total statements:"; procedure CHECK_OBJECT_NAMES_SIZE is separate; procedure CHECK_FOR_ATTRIBUTE( AT_THIS_TOKEN : in TOKENIZER.TOKEN ) is separate; procedure CHECK_UNIVERSAL ( THIS_TOKEN : TOKENIZER.TOKEN) is separate; begin -- Initialize the Nesting Stack -- JRM 2-20-85 NEST_HEADER.LEVEL := 0; NEST_HEADER.INDENT := 1; NEST_HEADER.STATEMENTS := 0; NEST_HEADER.KIND_OF_NEST := HEADER; NEST_HEADER.START_TOKEN := TOKENIZER.FIRST_TOKEN; NEST_STACK.PUSH( NEST_HEADER, MISC_NEST_STACK ); STYLE_PARAMETERS.RESERVED_WORD_INFO(STYLE_REPORT.KEYWORD_USAGE); STYLE_PARAMETERS.AVERAGE_SUBPROGRAM_SIZE (STYLE_REPORT.AVERAGE_SUBPROGRAM_SIZE_DESIRED_MINIMUM, STYLE_REPORT.AVERAGE_SUBPROGRAM_SIZE_DESIRED_MAXIMUM); STYLE_PARAMETERS.SUBPROGRAM_PARAMETERS (STYLE_REPORT.AVERAGE_NUMBER_OF_PARAMETERS_DESIRED_MINIMUM, STYLE_REPORT.AVERAGE_NUMBER_OF_PARAMETERS_DESIRED_MAXIMUM); begin loop CURRENT_TOKEN := GET_NEXT_TOKEN_AND_UPDATE_COUNT; -- First statement on the line if IS_STATEMENT(CURRENT_TOKEN) and TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN)/=WHILE_TOKEN and -- FOR and WHILE statements are covered by LOOP! TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN)/=FOR_TOKEN then CURRENT_STATUS.CURRENT_STATEMENTS := CURRENT_STATUS.CURRENT_STATEMENTS + 1; -- TEXT_IO.NEW_LINE; -- TOKENIZER.LINE_CONTAINING_TOKEN(CURRENT_TOKEN, SOURCE_LINE ); -- TEXT_IO.PUT("New Statement in line:"); -- TEXT_IO.PUT_LINE( DYN.STR( SOURCE_LINE ) ); -- Check declarations. if not CURRENT_STATUS.IN_BODY then -- Count declarations & universal types. CHECK_UNIVERSAL( CURRENT_TOKEN ); end if; end if; begin LOOK_AHEAD_TOKEN := TOKENIZER.PREVIOUS_TOKEN(CURRENT_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.END_OF_LINE then CURRENT_STATUS.TOTAL_LINES:=CURRENT_STATUS.TOTAL_LINES+1; if TOKENIZER.END_OF_LINE /= TOKENIZER.TYPE_OF_TOKEN_IS( CURRENT_TOKEN ) then -- Check for indentation at beginning of a -- NON-BLANK line! BEGIN_OF_LINE_INDENTATION(CURRENT_TOKEN); -- -- Check for multiple statements per line CHECK_STATEMENTS_PER_LINE( CURRENT_TOKEN ); else CURRENT_STATUS.TOTAL_BLANK_LINES := CURRENT_STATUS.TOTAL_BLANK_LINES + 1; end if; -- Does this work for floating divide? STYLE_REPORT.PERCENT_OF_BLANK_LINES_ACTUAL := FLOAT(CURRENT_STATUS.TOTAL_BLANK_LINES) / FLOAT(CURRENT_STATUS.TOTAL_LINES); end if; exception when TOKENIZER.END_OF_TOKENS => BEGIN_OF_LINE_INDENTATION(CURRENT_TOKEN); -- -- Check for multiple statements per line CHECK_STATEMENTS_PER_LINE( CURRENT_TOKEN ); when others => raise; end; case TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) is when TOKENIZER.KEYWORDS => RESERVE_WORD_ENCOUNTERED(CURRENT_TOKEN); when TOKENIZER.END_OF_LINE => NEW_LINE_TOKEN_ENCOUNTERED(CURRENT_TOKEN); when TOKENIZER.END_OF_FILE => if DYN.STR(FILE_NAME) = " " then FILE_NAME := TOKENIZER.EXTERNAL_REPRESENTATION( CURRENT_TOKEN); end if; when TOKENIZER.IDENTIFIER => OBJECT_NAME_ENCOUNTERED(CURRENT_TOKEN); when TOKENIZER.NUMERIC_LITERAL | TOKENIZER.STRING_LITERAL | TOKENIZER.CHARACTER_LITERAL => LITERAL_ENCOUNTERED(CURRENT_TOKEN); when TOKENIZER.SEMICOLON => null; when TOKENIZER.COMMENT => COMMENT_TOKEN_ENCOUNTERED(CURRENT_TOKEN); when TOKENIZER.TICK => CHECK_FOR_ATTRIBUTE(CURRENT_TOKEN); -- CONCATENATION_OPERATOR, RIGHT_PARENTHESIS, LEFT_PARENTHESIS, -- MULTIPLICATION_OPERATOR, ADDITION_OPERATOR, COMMA, SUBTRACTION_OPERATOR, -- PERIOD, DIVISION_OPERATOR, COLON, LESS_THAN_OPERATOR, EQUAL_OPERATOR, -- GREATER_THAN_OPERATOR, VERTICAL_BAR, ARROW, DOUBLE_DOT, -- EXPONENTIATE_OPERATOR, ASSIGNMENT_OPERATOR, INEQUAL_OPERATOR, -- GREATER_THAN_OR_EQUAL_OPERATOR, LESS_THAN_OR_EQUAL_OPERATOR, -- LEFT_LABEL_BRACKET, RIGHT_LABEL_BRACKET, BOX when TOKENIZER.ANYTHING_ELSE => for I in 1..DYN.LENGTH( TOKENIZER.EXTERNAL_REPRESENTATION(CURRENT_TOKEN)) loop case STYLE_PARAMETERS.CHARACTER_SET is -- letters and numbers will not be handled here -- Also most "Special characters" when STYLE_PARAMETERS.GRAPHIC => CH := DYN.STR(TOKENIZER. EXTERNAL_REPRESENTATION( CURRENT_TOKEN))(I); if CH /= ASCII.HT and CH /= ASCII.VT and CH /= ASCII.LF and CH /= ASCII.FF then REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE, CURRENT_TOKEN, "Illegal character " & "in this line", REPORT_GENERATOR.GRAPHIC_CHARACTER_USED); STYLE_REPORT.GRAPHIC_CHARACTERS_USED(CH) := STYLE_REPORT.GRAPHIC_CHARACTERS_USED(CH) + 1; end if; when STYLE_PARAMETERS.BASIC => CH := DYN.STR(TOKENIZER.EXTERNAL_REPRESENTATION( CURRENT_TOKEN))(I); REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE, CURRENT_TOKEN, "Illegal character " & "in this line", REPORT_GENERATOR.GRAPHIC_CHARACTER_USED); STYLE_REPORT.GRAPHIC_CHARACTERS_USED(CH) := STYLE_REPORT.GRAPHIC_CHARACTERS_USED(CH) + 1; when STYLE_PARAMETERS.EXTENDED => null; end case; end loop; when others => null; end case; end loop; exception when TOKENIZER.END_OF_TOKENS => null; when others => raise; end; -- check to see if there are no unmatched block on the nest stack CHECK_END_OF_BLOCKS; CHECK_OBJECT_NAMES_SIZE; if CURRENT_STATUS.IDENTIFIERS_INFORMATION.NUMBER_OF_ITEMS /= 0 then STYLE_REPORT.AVERAGE_NAME_SIZE_ACTUAL := FLOAT(CURRENT_STATUS.IDENTIFIERS_INFORMATION.TOTAL_SIZE_OF_ITEMS) / FLOAT(CURRENT_STATUS.IDENTIFIERS_INFORMATION.NUMBER_OF_ITEMS); end if; STYLE_REPORT.NUMBER_OF_COMMENTS := CURRENT_STATUS.COMMENT_INFORMATION.NUMBER_OF_ITEMS; if CURRENT_STATUS.COMMENT_INFORMATION.NUMBER_OF_ITEMS /= 0 then STYLE_REPORT.AVERAGE_COMMENT_SIZE_ACTUAL := FLOAT(CURRENT_STATUS.COMMENT_INFORMATION.TOTAL_SIZE_OF_ITEMS) / FLOAT(CURRENT_STATUS.COMMENT_INFORMATION.NUMBER_OF_ITEMS); end if; if CURRENT_STATUS.LITERAL_INFORMATION.NUMBER_OF_ITEMS /= 0 then STYLE_REPORT.PERCENT_OF_LITERALS_IN_BODY_ACTUAL := FLOAT(CURRENT_STATUS.LITERAL_INFORMATION.TOTAL_SIZE_OF_ITEMS) / FLOAT(CURRENT_STATUS.LITERAL_INFORMATION.NUMBER_OF_ITEMS); end if; if CURRENT_STATUS.UNIVERSAL_INFORMATION.NUMBER_OF_ITEMS /= 0 then STYLE_REPORT.PERCENT_OF_UNIVERSAL_TYPES_ACTUAL := FLOAT(CURRENT_STATUS.UNIVERSAL_INFORMATION.TOTAL_SIZE_OF_ITEMS) / FLOAT(CURRENT_STATUS.UNIVERSAL_INFORMATION.NUMBER_OF_ITEMS); end if; -- Print a final message of statement count! NEST_STACK.POP ( NEST_HEADER, MISC_NEST_STACK ); REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, NEST_HEADER.START_TOKEN, FINAL_MSG & INTEGER'IMAGE(NEST_HEADER.STATEMENTS) ); exception when TOKENIZER.END_OF_TOKENS => null; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in CHECK_THE_STYLE"); TEXT_IO.PUT_LINE("Trying to generate a Style Report anyway!"); CHECK_OBJECT_NAMES_SIZE; raise; end CHECK_THE_STYLE; :::::::::: checkfora.ada :::::::::: separate( STYLE_CHECKER.CHECK_THE_STYLE ) procedure CHECK_FOR_ATTRIBUTE ( AT_THIS_TOKEN : in TOKENIZER.TOKEN ) is -- ABSTRACT: Check whether this is an attribute and set the usage-flag. --------------------------------------------------------------------- -- PARAMETERS: AT_THIS_TOKEN is a token pointing to the TICK -- which we are trying to recognise as an attribute. ---------------------------------------------------------------------- -- ALGORITHM: A tick can either be an attribute or the separator -- before an aggregate. ---------------------------------------------------------------------- LOOKAHEAD : TOKENIZER.TOKEN; begin LOOKAHEAD := NEXT_NON_TRIVIAL_TOKEN( AT_THIS_TOKEN ); if TOKENIZER.TYPE_OF_TOKEN_IS( LOOKAHEAD ) /= TOKENIZER.LEFT_PARENTHESIS then CURRENT_USAGE.ATTRIBUTES := true; STYLE_REPORT.ATTRIBUTES_USED := true; end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in CHECK_FOR_ATTRIBUTE."); raise; end CHECK_FOR_ATTRIBUTE; :::::::::: checkobje.ada :::::::::: with TOKEN_DEFINITION; separate (STYLE_CHECKER.CHECK_THE_STYLE) procedure CHECK_OBJECT_NAMES_SIZE is -------------------------------------------------------------------------- -- Abstract : This routine calculates the name size information -- for the Style_Checker -------------------------------------------------------------------------- TREE_ROOT : TOKENIZER.IDENTIFIER_TREE := TOKENIZER.TREE_ROOT; TOTAL_VOWELS_IN_NAMES : NATURAL := 0; TOTAL_NAME_SEGMENTS : NATURAL := 0; TOTAL_CHARACTERS_IN_SEGMENTS: NATURAL := 0; SPELL_CHECK_WORD : TOKEN_DEFINITION.TOKEN_TYPE; FOUND : BOOLEAN; procedure TREE_FOLLOWER(T : in out TOKENIZER.IDENTIFIER_TREE) is begin if T /= null then -- traverse left tree TREE_FOLLOWER(T.LEFT); -- Update name segment information if DYN.LENGTH(T.REFERENCES.STRG) > STYLE_PARAMETERS.SMALL_WORD_SIZE then SPELL_CHECK_WORD.LENGTH := 0; for I in 1..DYN.LENGTH(T.REFERENCES.STRG) loop if (DYN.STR(T.REFERENCES.STRG)(I) = '_') then TOTAL_NAME_SEGMENTS := TOTAL_NAME_SEGMENTS + 1; DICTIONARY_MANAGER.TOKEN_IS_FOUND(STYLE_DICTIONARY, SPELL_CHECK_WORD, FOUND); if not FOUND then -- Not handled now... null; end if; SPELL_CHECK_WORD.LENGTH := 0; else if SPELL_CHECK_WORD.LENGTH < TOKEN_DEFINITION.TOKEN_LENGTH then SPELL_CHECK_WORD.LENGTH := SPELL_CHECK_WORD.LENGTH + 1; SPELL_CHECK_WORD.WORD(SPELL_CHECK_WORD.LENGTH) := DYN.STR(T.REFERENCES.STRG)(I); end if; TOTAL_CHARACTERS_IN_SEGMENTS := TOTAL_CHARACTERS_IN_SEGMENTS + 1; end if; end loop; TOTAL_NAME_SEGMENTS := TOTAL_NAME_SEGMENTS + 1; DICTIONARY_MANAGER.TOKEN_IS_FOUND(STYLE_DICTIONARY, SPELL_CHECK_WORD,FOUND); if not FOUND then -- Not handled now... null; end if; end if; -- Count characters and vowels for I in 1..DYN.LENGTH(T.REFERENCES.STRG) loop case DYN.STR(T.REFERENCES.STRG)(I) is when 'a' | 'e' | 'i' | 'o' | 'u' | 'y' | 'A' | 'E' | 'I' | 'O' | 'U' | 'Y' => TOTAL_VOWELS_IN_NAMES := TOTAL_VOWELS_IN_NAMES + 1; when others => null; end case; end loop; -- Update name length information CURRENT_STATUS.IDENTIFIERS_INFORMATION.NUMBER_OF_ITEMS := CURRENT_STATUS.IDENTIFIERS_INFORMATION.NUMBER_OF_ITEMS + 1; CURRENT_STATUS.IDENTIFIERS_INFORMATION.TOTAL_SIZE_OF_ITEMS := CURRENT_STATUS.IDENTIFIERS_INFORMATION.TOTAL_SIZE_OF_ITEMS + DYN.LENGTH(T.REFERENCES.STRG); -- traverse right tree TREE_FOLLOWER(T.RIGHT); end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in TREE_FOLLOWER"); raise; end TREE_FOLLOWER; begin TREE_FOLLOWER(TREE_ROOT); STYLE_REPORT.ABBREVIATIONS := TOTAL_CHARACTERS_IN_SEGMENTS /= 0 and then (FLOAT(TOTAL_VOWELS_IN_NAMES) / FLOAT(TOTAL_CHARACTERS_IN_SEGMENTS)) < STYLE_PARAMETERS.VOWEL_FREQUENCY; if TOTAL_NAME_SEGMENTS > 0 then STYLE_REPORT.NAME_SEGMENT_SIZE_ACTUAL := FLOAT(TOTAL_CHARACTERS_IN_SEGMENTS) / FLOAT(TOTAL_NAME_SEGMENTS); end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in CHECK_OBJECT_NAMES_SIZE"); raise; end CHECK_OBJECT_NAMES_SIZE; :::::::::: checkuniv.ada :::::::::: separate( STYLE_CHECKER.CHECK_THE_STYLE ) procedure CHECK_UNIVERSAL ( THIS_TOKEN : TOKENIZER.TOKEN ) is -- ABSTRACT: this procedure checks for the presence of a declaration -- which is a universal type. -- Parameters THIS_ToKEN points to the token which is the -- beginning of the declaration. use TOKENIZER; LOOKAHEAD : TOKENIZER.TOKEN; ID_COUNT : POSITIVE; -- Until declarations are parsed better, these will not be used! MIS_PARSED_DECLARATION : exception; MIS_PARSED_MSG : constant string := "Failed to parse declaration. Either Ada is wrong or this program in error!"; function IS_UNIVERSAL( TYPE_TOKEN : TOKENIZER.TOKEN ) return boolean is NAME : DYN.DYN_STRING; begin NAME := TOKENIZER.EXTERNAL_REPRESENTATION( TYPE_TOKEN ); return DYN.UPPER_CASE(NAME) = "INTEGER" or DYN.UPPER_CASE(NAME) = "SHORT_INTEGER" or DYN.UPPER_CASE(NAME) = "LONG_INTEGER" or DYN.UPPER_CASE(NAME) = "FLOAT" or DYN.UPPER_CASE(NAME) = "SHORT_FLOAT" or DYN.UPPER_CASE(NAME) = "LONG_FLOAT" or DYN.UPPER_CASE(NAME) = "NATURAL" or DYN.UPPER_CASE(NAME) = "POSITIVE"; end IS_UNIVERSAL; begin LOOKAHEAD := NEXT_NON_TRIVIAL_TOKEN( THIS_TOKEN ); case TOKENIZER.TYPE_OF_TOKEN_IS( THIS_TOKEN ) is when TOKENIZER.TYPE_TOKEN => CURRENT_STATUS.UNIVERSAL_INFORMATION.NUMBER_OF_ITEMS := CURRENT_STATUS.UNIVERSAL_INFORMATION.NUMBER_OF_ITEMS + 1; when TOKENIZER.SUBTYPE_TOKEN => CURRENT_STATUS.UNIVERSAL_INFORMATION.NUMBER_OF_ITEMS := CURRENT_STATUS.UNIVERSAL_INFORMATION.NUMBER_OF_ITEMS + 1; when TOKENIZER.IDENTIFIER => -- Find out how many identifiers ID_COUNT := 1; LOOKAHEAD := SEARCH_FORWARD_FOR_ONE_OF(THIS_TOKEN, TOKENIZER.COMMA,TOKENIZER.COLON); while TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD)=TOKENIZER.COMMA loop ID_COUNT := ID_COUNT + 1; LOOKAHEAD := SEARCH_FORWARD_FOR_ONE_OF(LOOKAHEAD, TOKENIZER.COMMA,TOKENIZER.COLON); end loop; CURRENT_STATUS.UNIVERSAL_INFORMATION.NUMBER_OF_ITEMS := CURRENT_STATUS.UNIVERSAL_INFORMATION.NUMBER_OF_ITEMS + ID_COUNT; if TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) = TOKENIZER.COLON then -- object declaration LOOKAHEAD := NEXT_NON_TRIVIAL_TOKEN( LOOKAHEAD ); -- look for exception or array if TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) = TOKENIZER.EXCEPTION_TOKEN or TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) = TOKENIZER.ARRAY_TOKEN then -- these are O.K.! null; else -- look for CONSTANT if TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) = TOKENIZER.CONSTANT_TOKEN then -- move to the identifier past CONSTANT! LOOKAHEAD := NEXT_NON_TRIVIAL_TOKEN( LOOKAHEAD ); end if; if TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) = TOKENIZER.IDENTIFIER then if IS_UNIVERSAL( LOOKAHEAD ) then CURRENT_STATUS.UNIVERSAL_INFORMATION. TOTAL_SIZE_OF_ITEMS := CURRENT_STATUS.UNIVERSAL_INFORMATION. TOTAL_SIZE_OF_ITEMS + ID_COUNT; end if; else null; -- We need to parse declarations better here before -- bad syntax can be noted! -- raise MIS_PARSED_DECLARATION; end if; end if; end if; when others => null; end case; exception when END_OF_TOKENS => REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, THIS_TOKEN, MIS_PARSED_MSG ); when MIS_PARSED_DECLARATION => REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, THIS_TOKEN, MIS_PARSED_MSG ); null; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in CHECK_UNIVERSAL."); raise; end CHECK_UNIVERSAL; :::::::::: commentto.ada :::::::::: separate (STYLE_CHECKER) procedure COMMENT_TOKEN_ENCOUNTERED ( FROM_THIS_TOKEN : TOKENIZER.TOKEN ) is -- ABSTRACT : This determines whether this is a 'trailing' comment, -- If it is, its indentation is checked. -- PARAMETERS : COMMENT_TOKEN is the token containing the comment to check. -- ALGORITHM : This is a trailing comment if: -- The indentation level is -- greater then current-indentation. -- The trailing indentation level is set when: -- The first trailing comment in a section is discovered (i.e. the -- old trailing-indent is 0), or -- Reset when a trailing comment has different indentation (this -- offending comment is flagged if the style requires, or -- Reset to 0 when a package, procedure, etc. is exited. use TOKENIZER; LOOKAROUND : TOKENIZER.TOKEN; LINE : TOKENIZER.LINE_NUM_RANGE; COLUMN : TOKENIZER.LINE_INDEX_RANGE; BAD_TRAILING_MSG : constant string := "The trailing comment here is inconsistantly indented."; begin -- Increment comment size counters CURRENT_STATUS.COMMENT_INFORMATION.NUMBER_OF_ITEMS := CURRENT_STATUS.COMMENT_INFORMATION.NUMBER_OF_ITEMS + 1; CURRENT_STATUS.COMMENT_INFORMATION.TOTAL_SIZE_OF_ITEMS := CURRENT_STATUS.COMMENT_INFORMATION.TOTAL_SIZE_OF_ITEMS + TOKENIZER.LENGTH_OF_COMMENT( FROM_THIS_TOKEN ); -- Check Trailing indentation? if STYLE_PARAMETERS.IS_COMMENT_INDENTATION_REQUIRED then -- The style says we should indent check indentation on trailing comments! LOOKAROUND := TOKENIZER.PREVIOUS_TOKEN( FROM_THIS_TOKEN ); TOKENIZER.TOKEN_POSITION( FROM_THIS_TOKEN, LINE, COLUMN ); if COLUMN > CURRENT_STATUS.CURRENT_INDENT then -- this is a trailing comment! if CURRENT_STATUS.CURRENT_TRAIL_COMMENT_INDENT = 0 then -- a first trailing comment! CURRENT_STATUS.CURRENT_TRAIL_COMMENT_INDENT := COLUMN; else if CURRENT_STATUS.CURRENT_TRAIL_COMMENT_INDENT /= COLUMN then -- Bad trailing comment! -- Reset the trailing indentation counter. CURRENT_STATUS.CURRENT_TRAIL_COMMENT_INDENT := COLUMN; REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, FROM_THIS_TOKEN, BAD_TRAILING_MSG, REPORT_GENERATOR.INCONSISTANT_INDENTATION); STYLE_REPORT.INCONSISTANT_INDENTATION := STYLE_REPORT.INCONSISTANT_INDENTATION + 1; end if; end if; end if; end if; exception when TOKENIZER.END_OF_TOKENS => -- First on the input. No handling required! null; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in COMMENT_TOKEN_ENCOUNTERED"); raise; end COMMENT_TOKEN_ENCOUNTERED; :::::::::: currentto.ada :::::::::: separate (STYLE_CHECKER) function CURRENT_TOKEN return TOKENIZER.TOKEN is -------------------------------------------------------------------------- -- Abstract : This function returns the token that is considered to be -- the current token for the Style_Checker. The current -- token is the last one "counted" by -- GET_NEXT_TOKEN_AND_UPDATE_COUNT. -------------------------------------------------------------------------- begin return CURRENT_STATUS.CURRENT_TOKEN; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in CURRENT_TOKEN"); raise; end CURRENT_TOKEN; :::::::::: enteringb.ada :::::::::: separate( STYLE_CHECKER ) procedure ENTERING_BLOCK_STRUCTURE( FROM_THIS_TOKEN : in TOKENIZER.TOKEN ) is -- ABSTRACT: This performs the operations necessary for entering a -- block structure. This initializes a record for the -- nesting stack, prepares for indentation. For Procedures, -- and functions, it counts parameters. -- -- PARAMETER: This is a token which is the beginning of the block. -- ALGORITHM: -- Check to make sure its the beginning of a block really. -- Increment previous nesting counter (Partial count of statements!) -- Prepare new nesting record. -- if FROM_THIS_TOKEN = procedure | function then -- Count parameters -- Check parameter limits -- end if; -- Push nesting record. -- Check indentation flag, and increment proper nesting counter; -- Nesting is checked for: -- Packages, -- Functions, procedures, and tasks -- Control Structures -- Begin -- Case -- Declare (special handling, this prefaces a 'begin' -- Do -- Exception (block) -- For -- Function -- Loop -- Package -- Procedure -- Record -- Select -- Task -- Then use TOKENIZER; NEW_NEST_REC : NESTING_RECORD; OLD_NEST_REC : NESTING_RECORD; SEARCH_TOKEN : TOKENIZER.TOKEN; PARAM_COUNT : natural; BAD_BLOCK_START : exception; SOURCE_LINE : DYN.DYN_STRING; SUBPROGRAM_NEST_EXCEEDED : constant string := "This subprogram is nested too deeply!"; PACKAGE_NEST_EXCEEDED : constant string := "This package is nested too deeply!"; CONTROL_NEST_EXCEEDED : constant string := "This control structure is nested too deeply!"; OVERFLOW_MSG : constant string := "This is nested so deep the stack overflowed! Further results are uncertain!"; UNDERFLOW_MSG : constant string := "The nesting stack has underflowed unexpectedly. Please check Ada syntax."; function SEARCH_FORWARD_FOR_ONE_OF ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE1 : TOKENIZER.TOKEN_TYPE; GOAL_TYPE2 : TOKENIZER.TOKEN_TYPE; GOAL_TYPE3 : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN is use TOKENIZER; -- This searches FORWARD until it finds one of the token types -- If the end of the list is found, the END_OF_FILE token is -- returned as a 'failed' signal. CURRENT_TOKEN : TOKENIZER.TOKEN; SOURCE_LINE : DYN.DYN_STRING; begin CURRENT_TOKEN := NEXT_NON_TRIVIAL_TOKEN( START_TOKEN ); while (TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= GOAL_TYPE1) and (TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= GOAL_TYPE2) and (TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= GOAL_TYPE3) loop if TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) = END_OF_FILE then exit; -- just return this token as a 'failed' signal. end if; CURRENT_TOKEN := NEXT_NON_TRIVIAL_TOKEN( CURRENT_TOKEN ); end loop; return CURRENT_TOKEN; exception when others => TEXT_IO.NEW_LINE; TEXT_IO.PUT("Inside SEARCH_FORWARD -- exception:" ); TEXT_IO.PUT_LINE(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("While in line:"); TOKENIZER.LINE_CONTAINING_TOKEN( START_TOKEN, SOURCE_LINE ); TEXT_IO.PUT( DYN.STR( SOURCE_LINE ) ); end SEARCH_FORWARD_FOR_ONE_OF; procedure HANDLE_PARAMETER_LIST( START : in TOKENIZER.TOKEN; PARAMETERS : out natural) is -- ABSTRACT: This locates a parameter (declaration) list. It -- counts the parameters on the list. This currently -- only handles function and procedures. (Entry and -- accept are other possibilities.) -- NOTE - It seems more obvious to do this as a function, -- however there may later be other things to do to parameter -- lists. -- PARAMETERS: START is a token which is the start of the statement -- (function or PROCEDURE). -- PARAMETERS is returned as the number of parameters on the list. -- ALGORITHM -- If there is a parameter list, it starts with a "(" two tokens -- past the START. Then each individual parameter is separated by a -- ";" with multiple names separated by ",". -- So the number of parameters is the number of ";" and "," before a ")". LOOKAHEAD : TOKENIZER.TOKEN; COUNT : natural; SMALL_LIMIT : natural; LARGE_LIMIT : natural; BAD_FORMAL_PART : exception; BAD_FORMAL_MSG : constant string := "The formal part is not recognized properly?"; TOO_FEW_PARAMS : constant string := "The number of parameters is BELOW the set limit!"; TOO_MANY_PARAMS : constant string := "The number of parameters is ABOVE the set limit!"; begin -- Make sure this is the proper kind of statement! case TOKENIZER.TYPE_OF_TOKEN_IS( START ) is when TOKENIZER.PROCEDURE_TOKEN | TOKENIZER.FUNCTION_TOKEN => -- Determine whether there is a "format_part". LOOKAHEAD := NEXT_NON_TRIVIAL_TOKEN( START ); LOOKAHEAD := NEXT_NON_TRIVIAL_TOKEN( LOOKAHEAD ); if TOKENIZER.TYPE_OF_TOKEN_IS( LOOKAHEAD ) = TOKENIZER.LEFT_PARENTHESIS then -- Number of parameters is number of ";" or "," -- between "(" and ")" plus one. COUNT := 1; LOOKAHEAD := SEARCH_FORWARD_FOR_ONE_OF( LOOKAHEAD, TOKENIZER.RIGHT_PARENTHESIS,TOKENIZER.SEMICOLON, TOKENIZER.COMMA); while TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) = TOKENIZER.SEMICOLON or TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) = TOKENIZER.COMMA loop COUNT := COUNT + 1; LOOKAHEAD := SEARCH_FORWARD_FOR_ONE_OF( LOOKAHEAD, TOKENIZER.RIGHT_PARENTHESIS,TOKENIZER.SEMICOLON, TOKENIZER.COMMA ); if TOKENIZER.TYPE_OF_TOKEN_IS( LOOKAHEAD ) = TOKENIZER.END_OF_FILE then -- cannot recognize the formal part properly. raise BAD_FORMAL_PART; end if; end loop; else COUNT := 0; end if; -- Check for the parameter range: STYLE_PARAMETERS.SUBPROGRAM_PARAMETERS( SMALL_LIMIT, LARGE_LIMIT); if COUNT < SMALL_LIMIT then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, START, TOO_FEW_PARAMS, REPORT_GENERATOR.TOO_FEW_PARAMETERS); STYLE_REPORT.INSTANCES_OF_PARAMETERS_BELOW_MINIMUM := STYLE_REPORT.INSTANCES_OF_PARAMETERS_BELOW_MINIMUM + 1; end if; if COUNT > LARGE_LIMIT then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, START, TOO_MANY_PARAMS, REPORT_GENERATOR.TOO_MANY_PARAMETERS); STYLE_REPORT.INSTANCES_OF_PARAMETERS_ABOVE_MAXIMUM := STYLE_REPORT.INSTANCES_OF_PARAMETERS_ABOVE_MAXIMUM + 1; end if; when others => COUNT := 0; end case; PARAMETERS := COUNT; return; exception when BAD_FORMAL_PART => TEXT_IO.NEW_LINE; TEXT_IO.PUT(BAD_FORMAL_MSG); when others => TEXT_IO.NEW_LINE; TEXT_IO.PUT("Inside HANDLE_PARAMETER_LIST -- exception:" ); TEXT_IO.PUT_LINE(CURRENT_EXCEPTION.NAME); end HANDLE_PARAMETER_LIST; begin -- All the checking should have been done before this! -- We should only be here if we're entering an actual block -- Handle nesting records NEST_STACK.POP( OLD_NEST_REC, MISC_NEST_STACK ); -- add on statements-to-date OLD_NEST_REC.STATEMENTS := OLD_NEST_REC.STATEMENTS + CURRENT_STATUS.CURRENT_STATEMENTS; CURRENT_STATUS.CURRENT_STATEMENTS := 0; NEST_STACK.PUSH( OLD_NEST_REC, MISC_NEST_STACK ); NEW_NEST_REC.INDENT := CURRENT_STATUS.CURRENT_INDENT; NEW_NEST_REC.STATEMENTS := 0; NEW_NEST_REC.START_TOKEN := FROM_THIS_TOKEN; NEW_NEST_REC.IN_BODY := CURRENT_STATUS.IN_BODY; CURRENT_STATUS.CURRENT_TRAIL_COMMENT_INDENT := 0; -- Determine kind of structure -- Possibilities are: case TOKENIZER.TYPE_OF_TOKEN_IS( FROM_THIS_TOKEN ) is -- Control blocks when TOKENIZER.BEGIN_TOKEN => ------------------------------------------------------- -- Check to see if preceeded by 'DECLARE' ------------------------------------------------------- CURRENT_STATUS.CONTROL_NEST_LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL + 1; NEW_NEST_REC.LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL; NEW_NEST_REC.KIND_OF_NEST := CONTROL_NEST; NEW_NEST_REC.PARAMETERS := 0; NEW_NEST_REC.START_TOKEN := FROM_THIS_TOKEN; when TOKENIZER.CASE_TOKEN | TOKENIZER.FOR_TOKEN | TOKENIZER.DECLARE_TOKEN | TOKENIZER.RECORD_TOKEN | TOKENIZER.SELECT_TOKEN => CURRENT_STATUS.CONTROL_NEST_LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL + 1; NEW_NEST_REC.LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL; NEW_NEST_REC.KIND_OF_NEST := CONTROL_NEST; NEW_NEST_REC.PARAMETERS := 0; NEW_NEST_REC.START_TOKEN := FROM_THIS_TOKEN; when TOKENIZER.DO_TOKEN => ------------------------------------------------------- -- ACCEPT is the beginning of the block! ------------------------------------------------------- SEARCH_TOKEN := SEARCH_BACKWARD(FROM_THIS_TOKEN, TOKENIZER.ACCEPT_TOKEN); CURRENT_STATUS.CONTROL_NEST_LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL + 1; NEW_NEST_REC.LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL; NEW_NEST_REC.KIND_OF_NEST := CONTROL_NEST; NEW_NEST_REC.PARAMETERS := 0; NEW_NEST_REC.START_TOKEN := SEARCH_TOKEN; when TOKENIZER.LOOP_TOKEN => -- FOR or WHILE may be the beginning of the block! -- Find the appropriate (if any) FOR or WHILE token. SEARCH_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN( FROM_THIS_TOKEN ); begin while not IS_STATEMENT( SEARCH_TOKEN ) loop SEARCH_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN( SEARCH_TOKEN ); end loop; exception when END_OF_TOKENS => null; when others => raise; end; CURRENT_STATUS.CONTROL_NEST_LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL + 1; NEW_NEST_REC.LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL; NEW_NEST_REC.KIND_OF_NEST := CONTROL_NEST; NEW_NEST_REC.PARAMETERS := 0; if TOKENIZER.TYPE_OF_TOKEN_IS(SEARCH_TOKEN)=TOKENIZER.WHILE_TOKEN or TOKENIZER.TYPE_OF_TOKEN_IS(SEARCH_TOKEN)=TOKENIZER.FOR_TOKEN then NEW_NEST_REC.START_TOKEN := SEARCH_TOKEN; else NEW_NEST_REC.START_TOKEN := FROM_THIS_TOKEN; end if; when TOKENIZER.THEN_TOKEN => -- IF is the beginning of the block! SEARCH_TOKEN := SEARCH_BACKWARD(FROM_THIS_TOKEN, TOKENIZER.IF_TOKEN); CURRENT_STATUS.CONTROL_NEST_LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL + 1; NEW_NEST_REC.LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL; NEW_NEST_REC.KIND_OF_NEST := CONTROL_NEST; NEW_NEST_REC.PARAMETERS := 0; NEW_NEST_REC.START_TOKEN := SEARCH_TOKEN; -- Package when TOKENIZER.PACKAGE_TOKEN => CURRENT_STATUS.PACKAGE_NEST_LEVEL := CURRENT_STATUS.PACKAGE_NEST_LEVEL + 1; CURRENT_STATUS.IN_BODY := FALSE; NEW_NEST_REC.LEVEL := CURRENT_STATUS.PACKAGE_NEST_LEVEL; NEW_NEST_REC.KIND_OF_NEST := PACKAGE_NEST; NEW_NEST_REC.PARAMETERS := 0; NEW_NEST_REC.START_TOKEN := FROM_THIS_TOKEN; -- Subprogram when TOKENIZER.FUNCTION_TOKEN | TOKENIZER.PROCEDURE_TOKEN => CURRENT_STATUS.PROCEDURE_NEST_LEVEL := CURRENT_STATUS.PROCEDURE_NEST_LEVEL + 1; CURRENT_STATUS.IN_BODY := FALSE; NEW_NEST_REC.LEVEL := CURRENT_STATUS.PROCEDURE_NEST_LEVEL; NEW_NEST_REC.KIND_OF_NEST := SUBPROGRAM_NEST; -- Find parameter list! HANDLE_PARAMETER_LIST( FROM_THIS_TOKEN, PARAM_COUNT ); NEW_NEST_REC.PARAMETERS := PARAM_COUNT; NEW_NEST_REC.START_TOKEN := FROM_THIS_TOKEN; when TOKENIZER.TASK_TOKEN => -- SUBPROGRAM? CURRENT_STATUS.PROCEDURE_NEST_LEVEL := CURRENT_STATUS.PROCEDURE_NEST_LEVEL + 1; CURRENT_STATUS.IN_BODY := FALSE; NEW_NEST_REC.LEVEL := CURRENT_STATUS.PROCEDURE_NEST_LEVEL; NEW_NEST_REC.KIND_OF_NEST := SUBPROGRAM_NEST; NEW_NEST_REC.PARAMETERS := 0; NEW_NEST_REC.START_TOKEN := FROM_THIS_TOKEN; when others => raise BAD_BLOCK_START; end case; -- Now check to see if nesting has exceeded maximum level case NEW_NEST_REC.KIND_OF_NEST is when SUBPROGRAM_NEST => if CURRENT_STATUS.PROCEDURE_NEST_LEVEL > STYLE_PARAMETERS.SUBPROGRAM_NESTING_LEVEL then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE,FROM_THIS_TOKEN, SUBPROGRAM_NEST_EXCEEDED, REPORT_GENERATOR.SUBPROGRAM_NESTED_TOO_DEEP); STYLE_REPORT.SUBPROGRAM_NESTING_EXCEEDING_MAXIMUM := STYLE_REPORT.SUBPROGRAM_NESTING_EXCEEDING_MAXIMUM + 1; end if; when PACKAGE_NEST => if CURRENT_STATUS.PACKAGE_NEST_LEVEL > STYLE_PARAMETERS.PACKAGE_NESTING_LEVEL then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE,FROM_THIS_TOKEN, PACKAGE_NEST_EXCEEDED, REPORT_GENERATOR.PACKAGE_NESTED_TOO_DEEP); STYLE_REPORT.PACKAGE_NESTING_EXCEEDING_MAXIMUM := STYLE_REPORT.PACKAGE_NESTING_EXCEEDING_MAXIMUM + 1; end if; when CONTROL_NEST => if CURRENT_STATUS.CONTROL_NEST_LEVEL > STYLE_PARAMETERS.CONTROL_NESTING_LEVEL then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE,FROM_THIS_TOKEN, CONTROL_NEST_EXCEEDED, REPORT_GENERATOR.CONTROL_STRUCTURE_NESTED_TOO_DEEP); STYLE_REPORT.CONTROL_STRUCTURE_NESTING_EXCEEDING_MAXIMUM := STYLE_REPORT.CONTROL_STRUCTURE_NESTING_EXCEEDING_MAXIMUM + 1; end if; when HEADER => null; end case; NEW_NEST_REC.EXITS := CURRENT_STATUS.EXITS_IN_LOOPS; CURRENT_STATUS.EXITS_IN_LOOPS := 0; -- Now push the Nesting record onto the stack! NEST_STACK.PUSH( NEW_NEST_REC, MISC_NEST_STACK ); -- Tag current indent markers; CURRENT_STATUS.BEGIN_INDENT := true; -- Flag indicating we're at the beginning of a block exception when BAD_BLOCK_START => TEXT_IO.NEW_LINE; TEXT_IO.PUT("Inside ENTERING_BLOCK -- exception:"); TEXT_IO.PUT(" A bad start-of-block token has been sent!"); when NEST_STACK.STACK_OVERFLOW => REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE, FROM_THIS_TOKEN, OVERFLOW_MSG, REPORT_GENERATOR.UNMATCHED_NESTING); when NEST_STACK.STACK_UNDERFLOW => REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE, FROM_THIS_TOKEN, UNDERFLOW_MSG, REPORT_GENERATOR.UNMATCHED_NESTING); when others => TEXT_IO.NEW_LINE; TEXT_IO.PUT("Inside ENTERING_BLOCK -- exception:" ); TEXT_IO.PUT_LINE(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT("While inside line:" ); TOKENIZER.LINE_CONTAINING_TOKEN(FROM_THIS_TOKEN, SOURCE_LINE ); TEXT_IO.PUT_LINE( DYN.STR( SOURCE_LINE ) ); end ENTERING_BLOCK_STRUCTURE; :::::::::: enterings.ada :::::::::: separate (STYLE_CHECKER) procedure ENTERING_SUB_BLOCK_STRUCTURE(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is -- ABSTRACT : This handles the case of intermediate levels of indentation -- without really entering a complete block such as -- the "else" within and if-then-else-endif statement. -- PARAMETER: This token points to the RESERVED WORD which starts a sub-block OLD_NEST_REC : NESTING_RECORD; -- for temporary POP! begin -- All we have to do is allow the indentation to reset! CURRENT_STATUS.BEGIN_INDENT := true; NEST_STACK.POP( OLD_NEST_REC, MISC_NEST_STACK ); -- Reset old indentation level! CURRENT_STATUS.CURRENT_INDENT := OLD_NEST_REC.INDENT; -- Restore nesting record! NEST_STACK.PUSH( OLD_NEST_REC, MISC_NEST_STACK ); exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in ENTERING_SUB_BLOCK_STRUCTURE"); raise; end ENTERING_SUB_BLOCK_STRUCTURE; :::::::::: exitingbl.ada :::::::::: separate( STYLE_CHECKER ) procedure EXITING_BLOCK_STRUCTURE( FROM_THIS_TOKEN : TOKENIZER.TOKEN ) is -- ABSTRACT: This cleans up after blocks, and does checks on the block -- which can now be done, i.e. loop name, size of block, etc. -- blank lines before the block. -- PARAMETERS: FROM_THIS_TOKEN is the token signifying the end of block. -- This will likely be and "END" word. -- ALGORITHM: Look to the Start of the block (The start token should be -- on the NEST-Stack). -- Figure out the number of statements in the structure (the -- nest-record should have a partial count and add to this -- the remainder statement count, including the 'end' statement. -- Determine the kind of structure. Record the size (counter) -- For subprograms determine whether it is past the limit. -- If Control-structure AND large-enough -- Check presence of LOOP-NAMES, blank lines around -- block. -- Reset the indentation counts. -- Reset the EXITs count if exiting a LOOP, FOR, or WHILE -- Reset the IN_BODY flag if this is a package or subprogram use TOKENIZER; use STYLE_PARAMETERS; package INT_IO is new TEXT_IO.INTEGER_IO( natural ); LOOKAROUND : TOKENIZER.TOKEN; START_BLOCK_TOKEN : TOKENIZER.TOKEN; TEMP_TOKEN_TYPE : TOKENIZER.TOKEN_TYPE; BLOCK_SIZE : natural; OLD_NEST_REC : NESTING_RECORD; LOOKBACK_NEST_REC : NESTING_RECORD; SMALL_LIMIT : natural; LARGE_LIMIT : natural; SOURCE_LINE : DYN.DYN_STRING; NO_BLANKS_FLAG : boolean := false; SUBPROGRAM_TOO_SMALL : constant string := "This subprogram is smaller than the defined limits!"; SUBPROGRAM_TOO_LARGE : constant string := "This subprogram is larger than the defined limits!"; MISSING_NAME_MSG : constant string := "This structure is large enough that it should have a loop-name!"; NO_BEGINNING_BLANKS_MSG : constant string := "This structure should have preceeding blank lines to set it off."; NO_TRAILING_BLANKS_MSG : constant string := "This structure should have following blank lines to set it off."; TOO_MANY_EXITS_MSG : constant string := "This loop has more EXITS than allowed by the style."; UNDERFLOW_MSG : constant string := "Too many ENDs. Check Ada syntax. Otherwise we didn't catch a block enter!"; begin NEST_STACK.POP( OLD_NEST_REC, MISC_NEST_STACK ); -- Reset to old indentation level CURRENT_STATUS.CURRENT_INDENT := OLD_NEST_REC.INDENT; CURRENT_STATUS.BEGIN_INDENT := false; -- this should be redundant! -- Check for error in our nesting detection! if OLD_NEST_REC.KIND_OF_NEST = HEADER then -- Try to partially recover by dummying a header record! NEST_STACK.PUSH( OLD_NEST_REC, MISC_NEST_STACK ); REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, FROM_THIS_TOKEN, UNDERFLOW_MSG,REPORT_GENERATOR.OTHER); end if; -- Determine the number of statements in the block -- NOTE! We may have to add one here to account for the 'end' statement -- depending on where we check for statements. BLOCK_SIZE := CURRENT_STATUS.CURRENT_STATEMENTS + OLD_NEST_REC.STATEMENTS; -- if OLD_NEST_REC.KIND_OF_NEST = CONTROL_NEST then -- TEXT_IO.NEW_LINE; -- TEXT_IO.PUT("Exiting a control block of "); -- INT_IO.PUT( BLOCK_SIZE ); -- TEXT_IO.PUT_LINE(" statements."); -- else -- TEXT_IO.NEW_LINE; -- LOOKAROUND := NEXT_NON_TRIVIAL_TOKEN( FROM_THIS_TOKEN ); -- TEXT_IO.PUT("Exiting PACKAGE/SUBPROGRAM " & -- DYN.STR(TOKENIZER.EXTERNAL_REPRESENTATION(LOOKAROUND)) -- & " of "); -- INT_IO.PUT( BLOCK_SIZE ); -- TEXT_IO.PUT_LINE(" statements."); -- end if; NEST_STACK.POP( LOOKBACK_NEST_REC, MISC_NEST_STACK ); -- Update statement count for enclosing block! LOOKBACK_NEST_REC.STATEMENTS := LOOKBACK_NEST_REC.STATEMENTS + BLOCK_SIZE; CURRENT_STATUS.CURRENT_STATEMENTS := 0; -- Get last IN_BODY status! CURRENT_STATUS.IN_BODY := LOOKBACK_NEST_REC.IN_BODY; -- Restore updated nest-record NEST_STACK.PUSH( LOOKBACK_NEST_REC, MISC_NEST_STACK ); -- Find beginning of loop START_BLOCK_TOKEN := OLD_NEST_REC.START_TOKEN; -- Is this loop of significant size? if BLOCK_SIZE > STYLE_PARAMETERS.SMALL_STRUCTURE_SIZE then ---------------------------------------- -- Check for blank lines before the loop. ---------------------------------------- -- check preceeding blank line declare PREV_TYPE : TOKENIZER.TOKEN_TYPE; begin -- for overrunning beginning of tokens! LOOKAROUND := SEARCH_BACKWARD( START_BLOCK_TOKEN,TOKENIZER.END_OF_LINE); -- End of previous line. If this is the only token on the line, -- then this is a blank line and it is O.K. -- NOTE: Is a comment equivalent to a blank line? -- For now, comments or 'withs' are o.k. PREV_TYPE := TOKENIZER.TYPE_OF_TOKEN_IS( PREVIOUS_TOKEN( LOOKAROUND )); if PREV_TYPE /= TOKENIZER.END_OF_LINE and PREV_TYPE /= TOKENIZER.COMMENT then -- look for with's! (USE is NOT acceptable) LOOKAROUND := SEARCH_BACKWARD( LOOKAROUND,TOKENIZER.END_OF_LINE); LOOKAROUND := TOKENIZER.NEXT_TOKEN(LOOKAROUND); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAROUND) = TOKENIZER.WITH_TOKEN or (TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAROUND) = TOKENIZER.IDENTIFIER and (TOKENIZER.TYPE_OF_TOKEN_IS(NEXT_TOKEN(LOOKAROUND)) = TOKENIZER.COLON) and (TOKENIZER.TYPE_OF_TOKEN_IS(NEXT_TOKEN(NEXT_TOKEN(LOOKAROUND))) = TOKENIZER.END_OF_LINE) ) then null; else REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, START_BLOCK_TOKEN, NO_BEGINNING_BLANKS_MSG, REPORT_GENERATOR.MISSING_BLANK_LINES_TO_SET_OFF_A_BLOCK); NO_BLANKS_FLAG := true; end if; end if; exception when END_OF_TOKENS => -- at beginning of tokens -- this shouldn't occur but is is acceptable. null; when others => raise; end; -- check following blank line begin -- for overrunning beginning of tokens! LOOKAROUND := SEARCH_FORWARD ( START_BLOCK_TOKEN,TOKENIZER.END_OF_LINE); -- End of this line. If the next token is END_OF_TOKEN -- then this is a blank line and it is O.K. -- NOTE: Is a comment equivalent to a blank line? if TOKENIZER.TYPE_OF_TOKEN_IS(TOKENIZER.NEXT_TOKEN (LOOKAROUND )) /= TOKENIZER.END_OF_LINE then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, START_BLOCK_TOKEN, NO_TRAILING_BLANKS_MSG, REPORT_GENERATOR.MISSING_BLANK_LINES_TO_SET_OFF_A_BLOCK); NO_BLANKS_FLAG := true; end if; exception when END_OF_TOKENS => -- at end of tokens -- this shouldn't occur but is is acceptable. null; when others => raise; end; if NO_BLANKS_FLAG then STYLE_REPORT.MISSING_BLANK_LINES_TO_SET_OFF_A_BLOCK := STYLE_REPORT.MISSING_BLANK_LINES_TO_SET_OFF_A_BLOCK + 1; end if; -- If this is a 'loop' (including for, and while). If so -- check for loop names! -- and the number of exits! TEMP_TOKEN_TYPE := TOKENIZER.TYPE_OF_TOKEN_IS(START_BLOCK_TOKEN); if TEMP_TOKEN_TYPE = TOKENIZER.LOOP_TOKEN or TEMP_TOKEN_TYPE = TOKENIZER.FOR_TOKEN or TEMP_TOKEN_TYPE = TOKENIZER.WHILE_TOKEN then if STYLE_PARAMETERS.LOOP_NAME_REQUIRED /= STYLE_PARAMETERS.NOT_REQUIRED then -- Check loop names LOOKAROUND := PREVIOUS_NON_TRIVIAL_TOKEN( START_BLOCK_TOKEN ); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAROUND) /= TOKENIZER.LEFT_LABEL_BRACKET then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, START_BLOCK_TOKEN, MISSING_NAME_MSG, REPORT_GENERATOR.LOOP_WITHOUT_NAME); STYLE_REPORT.LOOPS_WITHOUT_NAMES := STYLE_REPORT.LOOPS_WITHOUT_NAMES + 1; end if; end if; -- Check number of exits! if CURRENT_STATUS.EXITS_IN_LOOPS > STYLE_PARAMETERS.NUMBER_OF_LOOP_EXITS then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, START_BLOCK_TOKEN, TOO_MANY_EXITS_MSG, REPORT_GENERATOR.TOO_MANY_EXITS); STYLE_REPORT.INSTANCES_OF_TOO_MANY_EXITS := STYLE_REPORT.INSTANCES_OF_TOO_MANY_EXITS + 1; end if; -- reset "exits" counter -- This many not cover all the situations, but with good Ada -- input it should work CURRENT_STATUS.EXITS_IN_LOOPS := OLD_NEST_REC.EXITS; end if; end if; -- If in a Package-block then if OLD_NEST_REC.KIND_OF_NEST = PACKAGE_NEST then CURRENT_STATUS.CURRENT_TRAIL_COMMENT_INDENT := 0; end if; -- If a Subprogram-block then if OLD_NEST_REC.KIND_OF_NEST = SUBPROGRAM_NEST then CURRENT_STATUS.CURRENT_TRAIL_COMMENT_INDENT := 0; -- Check for the limits on subprogram size STYLE_PARAMETERS.AVERAGE_SUBPROGRAM_SIZE (SMALL_LIMIT, LARGE_LIMIT); if BLOCK_SIZE < SMALL_LIMIT then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, START_BLOCK_TOKEN, SUBPROGRAM_TOO_SMALL, REPORT_GENERATOR.SUBPROGRAM_SIZE_BELOW_MINIMUM); STYLE_REPORT.INSTANCES_OF_SIZE_BELOW_MINIMUM := STYLE_REPORT.INSTANCES_OF_SIZE_BELOW_MINIMUM + 1; elsif BLOCK_SIZE > LARGE_LIMIT then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, START_BLOCK_TOKEN, SUBPROGRAM_TOO_LARGE, REPORT_GENERATOR.SUBPROGRAM_SIZE_ABOVE_MAXIMUM); STYLE_REPORT.INSTANCES_OF_SIZE_ABOVE_MAXIMUM := STYLE_REPORT.INSTANCES_OF_SIZE_ABOVE_MAXIMUM + 1; end if; end if; -- Update the nexting counter case OLD_NEST_REC.KIND_OF_NEST is when PACKAGE_NEST => CURRENT_STATUS.PACKAGE_NEST_LEVEL := CURRENT_STATUS.PACKAGE_NEST_LEVEL - 1; when SUBPROGRAM_NEST => CURRENT_STATUS.PROCEDURE_NEST_LEVEL := CURRENT_STATUS.PROCEDURE_NEST_LEVEL - 1; when CONTROL_NEST => CURRENT_STATUS.CONTROL_NEST_LEVEL := CURRENT_STATUS.CONTROL_NEST_LEVEL - 1; when others => null; end case; exception when others => TEXT_IO.NEW_LINE; TEXT_IO.PUT("Inside EXITING_BLOCK_STRUCTURE -- exception:" ); TEXT_IO.PUT_LINE(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("While inside line:"); TOKENIZER.LINE_CONTAINING_TOKEN(FROM_THIS_TOKEN, SOURCE_LINE ); TEXT_IO.PUT_LINE( DYN.STR( SOURCE_LINE ) ); end EXITING_BLOCK_STRUCTURE; :::::::::: getnextto.ada :::::::::: separate (STYLE_CHECKER) function GET_NEXT_TOKEN_AND_UPDATE_COUNT return TOKENIZER.TOKEN is -------------------------------------------------------------------------- -- Abstract : This function gets the next "uncounted" token from the -- token stream and updates neccessary count information. -------------------------------------------------------------------------- begin if CURRENT_STATUS.CURRENT_LINE = 0 then CURRENT_STATUS.CURRENT_TOKEN := TOKENIZER.FIRST_TOKEN; CURRENT_STATUS.CURRENT_LINE := 1; else CURRENT_STATUS.CURRENT_TOKEN := TOKENIZER.NEXT_TOKEN(CURRENT_STATUS.CURRENT_TOKEN); end if; STYLE_REPORT.TOKEN_COUNT( TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_STATUS.CURRENT_TOKEN)) := STYLE_REPORT.TOKEN_COUNT( TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_STATUS.CURRENT_TOKEN)) + 1; return CURRENT_STATUS.CURRENT_TOKEN; exception when TOKENIZER.END_OF_TOKENS => raise; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in GET_NEXT_TOKEN_AND_UPDATE_COUNT"); raise; end GET_NEXT_TOKEN_AND_UPDATE_COUNT; :::::::::: isstateme.ada :::::::::: separate (STYLE_CHECKER) function IS_STATEMENT(EXAMINED_TOKEN : in TOKENIZER.TOKEN) return boolean is -- Determine whether or not this token is the start of a statement. -- Cases: If it is one of the following reserved words: -- IF (not after an END), END, FOR, USE (except rep specs), -- CASE (not after an 'END'), EXIT, GOTO, LOOP (not after an 'END'), TASK, -- TYPE, WITH, ABORT, BEGIN, DELAY, ENTRY, RAISE, WHILE, ACCEPT, -- PRAGMA, RETURN (not in a function declaration!), -- SELECT (not after an 'END'), PACKAGE, SUBTYPE, FUNCTION, -- EXCEPTION, PROCEDURE, TERMINATE. -- If the token is an IDENTIFIER -- AND -- The previous (significant) token is: -- ; => >> SELECT, THEN, ELSE, DO, IS, RECORD, OTHERS; -- AND -- This is not in a (..) pair (in this case this is a parameter declaration) -- THEN -- The token IS A STATEMENT start. use TOKENIZER; LOOKAHEAD : TOKENIZER.TOKEN; begin -- IS_STATEMENT begin case TOKENIZER.TYPE_OF_TOKEN_IS(EXAMINED_TOKEN) is when IF_TOKEN => LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(EXAMINED_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS (LOOKAHEAD) /= TOKENIZER.END_TOKEN then return true; else return false; end if; when END_TOKEN => return true; when FOR_TOKEN => return true; when USE_TOKEN => -- except rep specs LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(EXAMINED_TOKEN); return TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) /= TOKENIZER.IDENTIFIER; when CASE_TOKEN => -- not after an 'end' LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(EXAMINED_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS (LOOKAHEAD) /= TOKENIZER.END_TOKEN then return true; else return false; end if; when EXIT_TOKEN => return true; when GOTO_TOKEN => return true; when LOOP_TOKEN => -- not after an 'end' LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(EXAMINED_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS (LOOKAHEAD) /= TOKENIZER.END_TOKEN then return true; else return false; end if; when TASK_TOKEN => return true; when TYPE_TOKEN => return true; when WITH_TOKEN => return true; when ABORT_TOKEN => return true; when BEGIN_TOKEN => return true; when DELAY_TOKEN => return true; when ENTRY_TOKEN => return true; when RAISE_TOKEN => return true; when WHILE_TOKEN => return true; LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(EXAMINED_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS (LOOKAHEAD) /= TOKENIZER.END_TOKEN then return true; else return false; end if; when ACCEPT_TOKEN => return true; when PRAGMA_TOKEN => return true; -- when RECORD_TOKEN => when RETURN_TOKEN => LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(EXAMINED_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) /= TOKENIZER.RIGHT_PARENTHESIS and TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) /= TOKENIZER.IDENTIFIER then return true; else return false; end if; when SELECT_TOKEN => LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(EXAMINED_TOKEN); return TOKENIZER.TYPE_OF_TOKEN_IS ( LOOKAHEAD ) /= TOKENIZER.END_TOKEN; when PACKAGE_TOKEN => return true; when SUBTYPE_TOKEN => return true; when FUNCTION_TOKEN => return true; when SEPARATE_TOKEN => LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(EXAMINED_TOKEN); -- if declaration -> X : exception; -- then not a statement! return TOKENIZER.TYPE_OF_TOKEN_IS ( LOOKAHEAD ) /= TOKENIZER.IS_TOKEN; when EXCEPTION_TOKEN => LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(EXAMINED_TOKEN); -- if declaration -> X : exception; -- then not a statement! return TOKENIZER.TYPE_OF_TOKEN_IS ( LOOKAHEAD ) /= TOKENIZER.COLON; when PROCEDURE_TOKEN => return true; when TERMINATE_TOKEN => return true; when IDENTIFIER | NULL_TOKEN => if LEFT_PARENTHESIS = TOKENIZER.TYPE_OF_TOKEN_IS( SEARCH_BACKWARD_FOR_ONE_OF(EXAMINED_TOKEN, TOKENIZER.RIGHT_PARENTHESIS, TOKENIZER.LEFT_PARENTHESIS) ) then return false; -- Inside (..), i.e. parameter declaration else -- look at the last token LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(EXAMINED_TOKEN); case TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) is when TOKENIZER.SEMICOLON | TOKENIZER.ARROW | TOKENIZER.RIGHT_LABEL_BRACKET | TOKENIZER.DO_TOKEN | TOKENIZER.BEGIN_TOKEN | TOKENIZER.RECORD_TOKEN | TOKENIZER.OTHERS_TOKEN => return TRUE; when TOKENIZER.ELSE_TOKEN => LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(LOOKAHEAD); -- OR ELSE identifier is NOT a statement! return TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) /= TOKENIZER.OR_TOKEN; when TOKENIZER.THEN_TOKEN => LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(LOOKAHEAD); -- AND ELSE identifier is NOT a statement! return TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) /= TOKENIZER.AND_TOKEN; when TOKENIZER.LOOP_TOKEN | TOKENIZER.SELECT_TOKEN => -- could be "end loop identifier" LOOKAHEAD := PREVIOUS_NON_TRIVIAL_TOKEN(LOOKAHEAD); return TOKENIZER.TYPE_OF_TOKEN_IS(LOOKAHEAD) /= TOKENIZER.END_TOKEN; when TOKENIZER.IS_TOKEN => -- true only if at begin of declarations! return CURRENT_STATUS.BEGIN_INDENT and not CURRENT_STATUS.IN_BODY; when others => return false; end case; end if; when others => return false; end case; exception when END_OF_TOKENS => return TRUE; when others => raise; end; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in IS_STATEMENT"); raise; end IS_STATEMENT; :::::::::: literal.ada :::::::::: separate (STYLE_CHECKER) procedure LITERAL_ENCOUNTERED(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is -------------------------------------------------------------------------- -- Abstract : This procedure is called when a literal token is encountered. -------------------------------------------------------------------------- -- Parameters : FROM_THIS_TOKEN - token that is a literal -------------------------------------------------------------------------- -- Algorithm : Update the count of literals -- If in a body update literal size information -------------------------------------------------------------------------- begin CURRENT_STATUS.LITERAL_INFORMATION.NUMBER_OF_ITEMS := CURRENT_STATUS.LITERAL_INFORMATION.NUMBER_OF_ITEMS + 1; if CURRENT_STATUS.IN_BODY then CURRENT_STATUS.LITERAL_INFORMATION.TOTAL_SIZE_OF_ITEMS := CURRENT_STATUS.LITERAL_INFORMATION.TOTAL_SIZE_OF_ITEMS + 1; end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in LITERAL_ENCOUNTERED"); raise; end LITERAL_ENCOUNTERED; :::::::::: newlineto.ada :::::::::: separate (STYLE_CHECKER) procedure NEW_LINE_TOKEN_ENCOUNTERED(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is -------------------------------------------------------------------------- -- Abstract : This procedure is called when an end of line token is -- encountered. -------------------------------------------------------------------------- -- Parameters : FROM_THIS_TOKEN - Token that is an end of line -------------------------------------------------------------------------- -- Algorithm : Check the line length and output an error message if -- neccessary. -------------------------------------------------------------------------- LINE : TOKENIZER.LINE_NUM_RANGE; COLUMN : TOKENIZER.LINE_INDEX_RANGE; begin TOKENIZER.TOKEN_POSITION(FROM_THIS_TOKEN,LINE,COLUMN); if COLUMN > STYLE_PARAMETERS.LINE_SIZE then REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE,FROM_THIS_TOKEN, "This line exceeds maximum line length", REPORT_GENERATOR.LINE_EXCEEDING_LINE_LENGTH); STYLE_REPORT.NUMBER_OF_LINES_EXCEEDING_LINE_LENGTH := STYLE_REPORT.NUMBER_OF_LINES_EXCEEDING_LINE_LENGTH + 1; end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in NEW_LINE_TOKEN_ENCOUNTERED"); raise; end NEW_LINE_TOKEN_ENCOUNTERED; :::::::::: nontrivia.ada :::::::::: separate (STYLE_CHECKER) function PREVIOUS_NON_TRIVIAL_TOKEN(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) return TOKENIZER.TOKEN is -------------------------------------------------------------------------- -- Abstract : This function gets the last "non-trivial" token from the -- input token. -------------------------------------------------------------------------- -- Parameters : FROM_THIS_TOKEN - starting point in search for a "non-trivial" -- token. -------------------------------------------------------------------------- -- Algorithm : Starting at input token, go backward in token stream until -- a token that is not considered trivial is encountered. -- Specifically, trivial tokens are end_of_lines, comments, -- end_of_files, and garbage characters -------------------------------------------------------------------------- use TOKENIZER; RETURN_TOKEN : TOKENIZER.TOKEN; begin RETURN_TOKEN := TOKENIZER.PREVIOUS_TOKEN(FROM_THIS_TOKEN); while (TOKENIZER.TYPE_OF_TOKEN_IS(RETURN_TOKEN) = TOKENIZER.COMMENT) or (TOKENIZER.TYPE_OF_TOKEN_IS(RETURN_TOKEN) = TOKENIZER.END_OF_LINE) or (TOKENIZER.TYPE_OF_TOKEN_IS(RETURN_TOKEN) = TOKENIZER.END_OF_FILE) or (TOKENIZER.TYPE_OF_TOKEN_IS(RETURN_TOKEN) = TOKENIZER.ANYTHING_ELSE) loop RETURN_TOKEN := TOKENIZER.PREVIOUS_TOKEN(RETURN_TOKEN); end loop; return RETURN_TOKEN; exception when TOKENIZER.END_OF_TOKENS => raise; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in PREVIOUS_NON_TRIVIAL_TOKEN"); raise; end PREVIOUS_NON_TRIVIAL_TOKEN; separate (STYLE_CHECKER) function NEXT_NON_TRIVIAL_TOKEN(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) return TOKENIZER.TOKEN is -------------------------------------------------------------------------- -- Abstract : This function gets the next "non-trivial" token from the -- input token. -------------------------------------------------------------------------- -- Parameters : FROM_THIS_TOKEN - starting point in search for a "non-trivial" -- token. -------------------------------------------------------------------------- -- Algorithm : Starting at input token, go forward in token stream until -- a token that is not considered trivial is encountered. -- Specifically, trivial tokens are end_of_lines, comments, -- end_of_files, and garbage characters -------------------------------------------------------------------------- use TOKENIZER; RETURN_TOKEN : TOKENIZER.TOKEN; begin RETURN_TOKEN := TOKENIZER.NEXT_TOKEN(FROM_THIS_TOKEN); while (TOKENIZER.TYPE_OF_TOKEN_IS(RETURN_TOKEN) = TOKENIZER.COMMENT) or (TOKENIZER.TYPE_OF_TOKEN_IS(RETURN_TOKEN) = TOKENIZER.END_OF_LINE) or (TOKENIZER.TYPE_OF_TOKEN_IS(RETURN_TOKEN) = TOKENIZER.END_OF_FILE) or (TOKENIZER.TYPE_OF_TOKEN_IS(RETURN_TOKEN) = TOKENIZER.ANYTHING_ELSE) loop RETURN_TOKEN := TOKENIZER.NEXT_TOKEN(RETURN_TOKEN); end loop; return RETURN_TOKEN; exception when TOKENIZER.END_OF_TOKENS => raise; when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in NEXT_NON_TRIVIAL_TOKEN"); raise; end NEXT_NON_TRIVIAL_TOKEN; :::::::::: objectnam.ada :::::::::: separate (STYLE_CHECKER) procedure OBJECT_NAME_ENCOUNTERED(OBJECT_NAME_TOKEN : in TOKENIZER.TOKEN) is -------------------------------------------------------------------------- -- Abstract : This procedure is called when an object_name token is -- encountered. -------------------------------------------------------------------------- -- Parameters : OBJECT_NAME_TOKEN - token that is an object_name -------------------------------------------------------------------------- -- Algorithm : Check case of object name and output error message if -- neccessary. -------------------------------------------------------------------------- PHYSICAL_REPRESENTATION : DYN.DYN_STRING := TOKENIZER.EXTERNAL_REPRESENTATION(OBJECT_NAME_TOKEN); function CASELESS_CHAR( CHAR : in CHARACTER ) return boolean is -- This function checks for characters which should not effect -- the case of a name. -- This includes underscore '_' and numerics. begin return (CHAR = '_') or (CHAR >= '0' and CHAR <= '9'); end CASELESS_CHAR; begin -- Check case of object name case CURRENT_STATUS.CASE_OF_OBJECT_NAMES is when STYLE_PARAMETERS.NAME_CASE_UPPER => for I in 1..DYN.LENGTH(PHYSICAL_REPRESENTATION) loop if ((DYN.STR(PHYSICAL_REPRESENTATION)(I) < 'A') or (DYN.STR(PHYSICAL_REPRESENTATION)(I) > 'Z')) and not CASELESS_CHAR(DYN.STR(PHYSICAL_REPRESENTATION)(I)) then REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE,OBJECT_NAME_TOKEN, "Object name " & DYN.STR(PHYSICAL_REPRESENTATION) & " should be in upper case", REPORT_GENERATOR.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER); STYLE_REPORT.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER := STYLE_REPORT.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER + 1; exit; end if; end loop; when STYLE_PARAMETERS.NAME_CASE_LOWER => for I in 1..DYN.LENGTH(PHYSICAL_REPRESENTATION) loop if ((DYN.STR(PHYSICAL_REPRESENTATION)(I) < 'a') or (DYN.STR(PHYSICAL_REPRESENTATION)(I) > 'z')) and not CASELESS_CHAR(DYN.STR(PHYSICAL_REPRESENTATION)(I)) then REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE,OBJECT_NAME_TOKEN, "Object name " & DYN.STR(PHYSICAL_REPRESENTATION) & " should be in lower case", REPORT_GENERATOR.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER); STYLE_REPORT.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER := STYLE_REPORT.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER + 1; exit; end if; end loop; when STYLE_PARAMETERS.NAME_CASE_CONSISTANT => -- This will only be selected if this is the first object name -- encountered, in which case it will be used to decide which case -- to use. if (DYN.STR(PHYSICAL_REPRESENTATION)(1) >= 'a') and (DYN.STR(PHYSICAL_REPRESENTATION)(1) <= 'z') then CURRENT_STATUS.CASE_OF_OBJECT_NAMES := STYLE_PARAMETERS.NAME_CASE_LOWER; for I in 2..DYN.LENGTH(PHYSICAL_REPRESENTATION) loop if ((DYN.STR(PHYSICAL_REPRESENTATION)(I) < 'a') or (DYN.STR(PHYSICAL_REPRESENTATION)(I) > 'z')) and not CASELESS_CHAR(DYN.STR(PHYSICAL_REPRESENTATION)(I)) then CURRENT_STATUS.CASE_OF_OBJECT_NAMES := STYLE_PARAMETERS.NAME_CASE_ANY; exit; end if; end loop; elsif (DYN.STR(PHYSICAL_REPRESENTATION)(2) >= 'a') and (DYN.STR(PHYSICAL_REPRESENTATION)(2) <= 'z') then CURRENT_STATUS.CASE_OF_OBJECT_NAMES := STYLE_PARAMETERS.NAME_CASE_FIRST_CAPITALIZED; for I in 3..DYN.LENGTH(PHYSICAL_REPRESENTATION) loop if ((DYN.STR(PHYSICAL_REPRESENTATION)(I) < 'a') or (DYN.STR(PHYSICAL_REPRESENTATION)(I) > 'z')) and not CASELESS_CHAR(DYN.STR(PHYSICAL_REPRESENTATION)(I)) then CURRENT_STATUS.CASE_OF_OBJECT_NAMES := STYLE_PARAMETERS.NAME_CASE_ANY; exit; end if; end loop; else CURRENT_STATUS.CASE_OF_OBJECT_NAMES := STYLE_PARAMETERS.NAME_CASE_UPPER; for I in 2..DYN.LENGTH(PHYSICAL_REPRESENTATION) loop if ((DYN.STR(PHYSICAL_REPRESENTATION)(I) < 'A') or (DYN.STR(PHYSICAL_REPRESENTATION)(I) > 'Z')) and not CASELESS_CHAR(DYN.STR(PHYSICAL_REPRESENTATION)(I)) then CURRENT_STATUS.CASE_OF_OBJECT_NAMES := STYLE_PARAMETERS.NAME_CASE_ANY; exit; end if; end loop; end if; when STYLE_PARAMETERS.NAME_CASE_FIRST_CAPITALIZED => if ((DYN.STR(PHYSICAL_REPRESENTATION)(1) < 'A') or (DYN.STR(PHYSICAL_REPRESENTATION)(1) > 'Z')) then REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE,OBJECT_NAME_TOKEN, "Object name " & DYN.STR(PHYSICAL_REPRESENTATION) & " should have first character capitalized ", REPORT_GENERATOR.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER); STYLE_REPORT.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER := STYLE_REPORT.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER + 1; else for I in 1..DYN.LENGTH(PHYSICAL_REPRESENTATION) loop if ((DYN.STR(PHYSICAL_REPRESENTATION)(I) < 'A') or (DYN.STR(PHYSICAL_REPRESENTATION)(I) > 'Z')) and not CASELESS_CHAR(DYN.STR(PHYSICAL_REPRESENTATION)(I)) then REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE,OBJECT_NAME_TOKEN, "Object name " & DYN.STR(PHYSICAL_REPRESENTATION) & " should have all but first character in lower" & " case", REPORT_GENERATOR.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER); STYLE_REPORT.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER := STYLE_REPORT.INVALID_CASE_FOR_AN_OBJECT_IDENTIFIER + 1; exit; end if; end loop; end if; when STYLE_PARAMETERS.NAME_CASE_ANY => null; end case; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in OBJECT_NAME_ENCOUNTERED"); raise; end OBJECT_NAME_ENCOUNTERED; :::::::::: reservewo.ada :::::::::: separate (STYLE_CHECKER) procedure RESERVE_WORD_ENCOUNTERED(RESERVE_WORD_TOKEN : in TOKENIZER.TOKEN) is -------------------------------------------------------------------------- -- Abstract : This procedure handles reserve word tokens. -------------------------------------------------------------------------- -- Parameters : RESERVE_WORD_TOKEN - token that is a reserve_word -------------------------------------------------------------------------- -- Algorithm : Check case of reserve word, outputing necessary error -- messages. -- Do a case on the reserve word, handling each appropriately -------------------------------------------------------------------------- use TOKENIZER; use STYLE_PARAMETERS; PHYSICAL_REPRESENTATION : DYN.DYN_STRING; LOOK_AHEAD_TOKEN : TOKENIZER.TOKEN; NAME_TOKEN : TOKENIZER.TOKEN; SEPARATOR_TYPE : TOKENIZER.TOKEN_TYPE; LINE : TOKENIZER.LINE_NUM_RANGE; COLUMN : TOKENIZER.LINE_INDEX_RANGE; OLD_NEST_REC : NESTING_RECORD; -- used for manipulation -- of IN_BODY detection! PRAGMA_NAME : DYN.DYN_STRING; PREDEFINED_PRAGMA_MSG : constant string := "Transportability Note: Pragma."; NON_STANDARD_PRAGMA_MSG : constant string := "Transportability Note: Non-Standard Pragma!"; ADDRESS_CLAUSE_MSG : constant string := "This may be a non-transportable statement (Address Clause)."; REPRESENTATION_SPECS_MSG : constant string := "This may be a non-transportable statement (Representation Specification)."; BAD_PACKAGE_MSG : constant string := "This package is on the list of packages to be warned against."; function MATCH_PAREN(LEFT_PAREN : in TOKENIZER.TOKEN) RETURN TOKENIZER.TOKEN; procedure PACKAGE_TOKEN_HANDLER(RESERVE_WORD_TOKEN : in TOKENIZER.TOKEN); procedure TASK_TOKEN_HANDLER(RESERVE_WORD_TOKEN : in TOKENIZER.TOKEN); procedure FUNCTION_PROCEDURE_TOKENS_HANDLER( RESERVE_WORD_TOKEN : in TOKENIZER.TOKEN); function MATCH_PAREN(LEFT_PAREN : in TOKENIZER.TOKEN) RETURN TOKENIZER.TOKEN is NEXT_PAREN : TOKENIZER.TOKEN := LEFT_PAREN; begin NEXT_PAREN := NEXT_TOKEN(NEXT_PAREN); loop NEXT_PAREN := SEARCH_FORWARD_FOR_ONE_OF(NEXT_PAREN, TOKENIZER.RIGHT_PARENTHESIS, TOKENIZER.LEFT_PARENTHESIS); if TYPE_OF_TOKEN_IS(NEXT_PAREN) = TOKENIZER.LEFT_PARENTHESIS then NEXT_PAREN := MATCH_PAREN(NEXT_PAREN); else exit; end if; end loop; return NEXT_PAREN; end MATCH_PAREN; procedure PACKAGE_TOKEN_HANDLER(RESERVE_WORD_TOKEN : in TOKENIZER.TOKEN) is LOOK_AHEAD_TOKEN : TOKENIZER.TOKEN; begin -- ******************************* -- When a PACKAGE token is encountered there are five -- possibilities of context: -- 1. PACKAGE specification -- 2. PACKAGE BODY -- 3. Rename of a package -- 4. Instantiation of a generic package -- 5. PACKAGE BODY <name> IS SEPARATE -- ******************************* LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.BODY_TOKEN then -- skip package name (an indentifier) LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); -- skip IS token LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); -- get next token after IS LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.SEPARATE_TOKEN then -- 2. Package body CURRENT_STATUS.IN_GENERIC := FALSE; ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); -- else -- 5. package body <name> is separate end if; else -- either -- 1. Package specification -- 3. Rename of a package -- 4. Instantiation of a generic package LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.RENAMES_TOKEN then LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.NEW_TOKEN then -- 1. Package specification CURRENT_STATUS.IN_GENERIC := FALSE; ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); -- else -- 4. Instantiation of a generic package end if; -- else -- 3. Rename of a package end if; end if; end PACKAGE_TOKEN_HANDLER; procedure TASK_TOKEN_HANDLER(RESERVE_WORD_TOKEN : in TOKENIZER.TOKEN) is LOOK_AHEAD_TOKEN : TOKENIZER.TOKEN; begin LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.BODY_TOKEN then -- TASK BODY task_simple_name IS ... -- or -- TASK BODY task_simple_name IS SEPARATE ; -- skip the identifier LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); -- skip the "IS" LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.SEPARATE_TOKEN then ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); end if; else -- TASK [TYPE] identifier -- or -- TASK [TYPE] identifier IS ... if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.TYPE_TOKEN then -- skip the TYPE token LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); end if; -- skip the identifier LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.IS_TOKEN then ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); end if; end if; end TASK_TOKEN_HANDLER; procedure FUNCTION_PROCEDURE_TOKENS_HANDLER( RESERVE_WORD_TOKEN : in TOKENIZER.TOKEN) is LOOK_AHEAD_TOKEN : TOKENIZER.TOKEN; begin begin LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); exception when TOKENIZER.END_OF_TOKENS => LOOK_AHEAD_TOKEN := RESERVE_WORD_TOKEN; -- not a WITH! when others => raise; end; if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = WITH_TOKEN then -- WITH subprogram_specification [IS__name__or__<>] ; null; else LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); -- skip the identifier LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = LEFT_PARENTHESIS then LOOK_AHEAD_TOKEN := MATCH_PAREN(LOOK_AHEAD_TOKEN); LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); end if; -- for FUNCTION spec, pass by "return type_mark" if TOKENIZER.TYPE_OF_TOKEN_IS(RESERVE_WORD_TOKEN) = FUNCTION_TOKEN then LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); while TOKENIZER.TYPE_OF_TOKEN_IS( LOOK_AHEAD_TOKEN ) = TOKENIZER.PERIOD loop -- This is an expanded name, i.e. name.name.name LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); end loop; end if; if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = RENAMES_TOKEN then -- subprogram_specification RENAMES subprogram_or_entry_name ; null; elsif TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = IS_TOKEN then LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = NEW_TOKEN then -- FUNCTION designator IS -- NEW generic_function_name [generic_actual_part] ; -- or -- PROCEDURE identifier IS -- NEW generic_procedure_name [generic_actual_part] ; null; elsif TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = SEPARATE_TOKEN then -- subprogram_specification IS SEPARATE ; null; else -- subprogram_body ::= -- subprogram_specification IS ... ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); CURRENT_STATUS.IN_GENERIC := FALSE; end if; else -- Subprogram specification null; end if; end if; end FUNCTION_PROCEDURE_TOKENS_HANDLER; begin -- RESERVE_WORD_ENCOUNTERED -- Check case of reserve word case CURRENT_STATUS.CASE_OF_RESERVED_WORDS is when STYLE_PARAMETERS.RESERVED_CASE_UPPER => PHYSICAL_REPRESENTATION := TOKENIZER.EXTERNAL_REPRESENTATION(RESERVE_WORD_TOKEN); for I in 1..DYN.LENGTH(PHYSICAL_REPRESENTATION) loop if (DYN.STR(PHYSICAL_REPRESENTATION)(I) < 'A') or (DYN.STR(PHYSICAL_REPRESENTATION)(I) > 'Z') then REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE,RESERVE_WORD_TOKEN, "Reserve word " & DYN.STR(PHYSICAL_REPRESENTATION) & " should be in upper case", REPORT_GENERATOR.INVALID_CASE_FOR_A_KEYWORD); STYLE_REPORT.INVALID_CASE_FOR_A_KEYWORD := STYLE_REPORT.INVALID_CASE_FOR_A_KEYWORD + 1; exit; end if; end loop; when STYLE_PARAMETERS.RESERVED_CASE_LOWER => PHYSICAL_REPRESENTATION := TOKENIZER.EXTERNAL_REPRESENTATION(RESERVE_WORD_TOKEN); for I in 1..DYN.LENGTH(PHYSICAL_REPRESENTATION) loop if (DYN.STR(PHYSICAL_REPRESENTATION)(I) < 'a') or (DYN.STR(PHYSICAL_REPRESENTATION)(I) > 'z') then REPORT_GENERATOR.PUT_FLAW(FLAWS_FILE,RESERVE_WORD_TOKEN, "Reserve word " & DYN.STR(PHYSICAL_REPRESENTATION) & " should be in lower case", REPORT_GENERATOR.INVALID_CASE_FOR_A_KEYWORD); STYLE_REPORT.INVALID_CASE_FOR_A_KEYWORD := STYLE_REPORT.INVALID_CASE_FOR_A_KEYWORD + 1; exit; end if; end loop; when STYLE_PARAMETERS.RESERVED_CASE_CONSISTANT => -- This will only be selected if this is the first reserve word -- encountered, in which case it will be used to decide which case -- to use. PHYSICAL_REPRESENTATION := TOKENIZER.EXTERNAL_REPRESENTATION(RESERVE_WORD_TOKEN); if (DYN.STR(PHYSICAL_REPRESENTATION)(1) >= 'a') and (DYN.STR(PHYSICAL_REPRESENTATION)(1) <= 'z') then CURRENT_STATUS.CASE_OF_RESERVED_WORDS := STYLE_PARAMETERS.RESERVED_CASE_LOWER; for I in 2..DYN.LENGTH(PHYSICAL_REPRESENTATION) loop if (DYN.STR(PHYSICAL_REPRESENTATION)(I) < 'a') or (DYN.STR(PHYSICAL_REPRESENTATION)(I) > 'z') then CURRENT_STATUS.CASE_OF_RESERVED_WORDS := STYLE_PARAMETERS.RESERVED_CASE_ANY; exit; end if; end loop; else CURRENT_STATUS.CASE_OF_RESERVED_WORDS := STYLE_PARAMETERS.RESERVED_CASE_UPPER; for I in 2..DYN.LENGTH(PHYSICAL_REPRESENTATION) loop if (DYN.STR(PHYSICAL_REPRESENTATION)(I) < 'A') or (DYN.STR(PHYSICAL_REPRESENTATION)(I) > 'Z') then CURRENT_STATUS.CASE_OF_RESERVED_WORDS := STYLE_PARAMETERS.RESERVED_CASE_ANY; exit; end if; end loop; end if; when STYLE_PARAMETERS.RESERVED_CASE_ANY => null; end case; case TOKENIZER.TYPE_OF_TOKEN_IS(RESERVE_WORD_TOKEN) is when ABORT_TOKEN => null; when ABS_TOKEN => null; when ACCEPT_TOKEN => null; when ACCESS_TOKEN => null; when ALL_TOKEN => null; when AND_TOKEN => null; when ARRAY_TOKEN => -- Array data structuring used! STYLE_REPORT.DATA_STRUCTURING_TYPES_NOT_USED( REPORT_GENERATOR.ARRAY_TYPES):=false; when AT_TOKEN => null; when BEGIN_TOKEN => -- Either a block statement or a "body" if CURRENT_STATUS.IN_BODY then ENTERING_BLOCK_STRUCTURE( RESERVE_WORD_TOKEN ); else CURRENT_STATUS.IN_BODY := TRUE; -- Reset this block's IN_BODY status! NEST_STACK.POP( OLD_NEST_REC, MISC_NEST_STACK ); OLD_NEST_REC.IN_BODY := TRUE; NEST_STACK.PUSH( OLD_NEST_REC, MISC_NEST_STACK ); ENTERING_SUB_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); end if; when BODY_TOKEN => null; when CASE_TOKEN => -- Two possibilities -- 1. Start of an CASE statement -- 2. End of an CASE statement LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if (TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.END_TOKEN) then ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); end if; when CONSTANT_TOKEN => null; when DECLARE_TOKEN => CURRENT_STATUS.IN_BODY := FALSE; ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); when DELAY_TOKEN => null; when DELTA_TOKEN => null; when DIGITS_TOKEN => null; when DO_TOKEN => -- Must accept statement block ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); when ELSE_TOKEN => -- Two possibilities -- 1. ELSE in an if or select -- 2. OR ELSE in an expression LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if (TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.OR_TOKEN) then null; else STYLE_REPORT.OR_ELSES_USED := TRUE; end if; when ELSIF_TOKEN => STYLE_REPORT.ELSIFS_USED := TRUE; when END_TOKEN => EXITING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); when ENTRY_TOKEN => null; when EXCEPTION_TOKEN => null; -- Two possibilities -- 1. Exception block -- 2. Exception declaration LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if (TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.COLON) then ENTERING_SUB_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); STYLE_REPORT.EXCEPTIONS_USED := TRUE; end if; when EXIT_TOKEN => -- Handle exit in loop counting (only possibility) CURRENT_STATUS.EXITS_IN_LOOPS := CURRENT_STATUS.EXITS_IN_LOOPS + 1; STYLE_REPORT.EXITS_USED := TRUE; when FOR_TOKEN => -- Three possibilities exist. -- 1. FOR loop -- 2. FOR attribute USE ... -- 3. FOR name USE -- 1 implies entering a block structure, but will be -- handled when the LOOP is encountered -- 2 and 3 imply non-transportable things. -- To figure out which one we must look forward two -- tokens. LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); if (TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.USE_TOKEN) or (TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.TICK) then -- This is a Representation-specification or address clause. -- If the current case is: "USE AT" then this is an -- address clause, else Rep Spec. LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(LOOK_AHEAD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.AT_TOKEN then -- Address Clauses STYLE_REPORT.ADDRESS_CLAUSES := STYLE_REPORT.ADDRESS_CLAUSES + 1; if not STYLE_PARAMETERS.ADDRESS_CLAUSE_ALLOWED then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, RESERVE_WORD_TOKEN,ADDRESS_CLAUSE_MSG, REPORT_GENERATOR.ADDRESS_CLAUSE_USED); end if; else -- Representation Specifications STYLE_REPORT.REPRESENTATION_SPECIFICATIONS := STYLE_REPORT.REPRESENTATION_SPECIFICATIONS + 1; if not STYLE_PARAMETERS.REPRESENTATION_SPECS_ALLOWED then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, RESERVE_WORD_TOKEN,REPRESENTATION_SPECS_MSG, REPORT_GENERATOR.REPRESENTATION_SPECIFICATION_USED); end if; end if; end if; when FUNCTION_TOKEN => FUNCTION_PROCEDURE_TOKENS_HANDLER(RESERVE_WORD_TOKEN); when GENERIC_TOKEN => ENTERING_SUB_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); CURRENT_STATUS.IN_GENERIC := TRUE; when GOTO_TOKEN => null; when IF_TOKEN => null; -- Two possibilities -- 1. Start of an IF statement - will be handled when -- the THEN is encountered -- 2. End of an IF statement - will have been handled on the -- END statement when IN_TOKEN => LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN ( RESERVE_WORD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.OUT_TOKEN then STYLE_REPORT.IN_OUTS_USED := TRUE; else STYLE_REPORT.INS_USED := TRUE; end if; when IS_TOKEN => null; when LIMITED_TOKEN => null; when LOOP_TOKEN => LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if (TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.END_TOKEN) then ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); end if; when MOD_TOKEN => null; when NEW_TOKEN => null; when NOT_TOKEN => null; when NULL_TOKEN => null; when OF_TOKEN => null; when OR_TOKEN => null; when OTHERS_TOKEN => null; when OUT_TOKEN => LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.IN_TOKEN then STYLE_REPORT.OUTS_USED := TRUE; end if; when PACKAGE_TOKEN => PACKAGE_TOKEN_HANDLER(RESERVE_WORD_TOKEN); when PRAGMA_TOKEN => null; -- Handle PRAGMA checks LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); PRAGMA_NAME := TOKENIZER.EXTERNAL_REPRESENTATION( LOOK_AHEAD_TOKEN ); if STYLE_PARAMETERS.IS_A_PREDEFINED_PRAGMA(PRAGMA_NAME) then REPORT_GENERATOR.INSERT_INTO_LIST( STYLE_REPORT.PRAGMAS_USED, PRAGMA_NAME ); if STYLE_PARAMETERS.NOTE_PRAGMAS = STYLE_PARAMETERS.ALL_PRAGMAS then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, RESERVE_WORD_TOKEN, PREDEFINED_PRAGMA_MSG, REPORT_GENERATOR.PRAGMA_USED); end if; else REPORT_GENERATOR.INSERT_INTO_LIST( STYLE_REPORT.NON_STANDARD_PRAGMAS_USED, PRAGMA_NAME ); if STYLE_PARAMETERS.NOTE_PRAGMAS/= STYLE_PARAMETERS.NONE then REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, RESERVE_WORD_TOKEN, NON_STANDARD_PRAGMA_MSG, REPORT_GENERATOR.NON_STANDARD_PRAGMA_USED); end if; end if; when PRIVATE_TOKEN => STYLE_REPORT.PRIVATES_USED := TRUE; -- Either a type declaration or private part LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if (TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.IS_TOKEN) and (TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.LIMITED_TOKEN) then ENTERING_SUB_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); end if; when PROCEDURE_TOKEN => FUNCTION_PROCEDURE_TOKENS_HANDLER(RESERVE_WORD_TOKEN); when RAISE_TOKEN => null; when RANGE_TOKEN => null; when RECORD_TOKEN => null; -- Either entering or exiting record declaration LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if (TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.END_TOKEN) then ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); -- Record types are used! This includes their use in -- representation specifications. STYLE_REPORT.DATA_STRUCTURING_TYPES_NOT_USED( REPORT_GENERATOR.RECORD_TYPES) := false; end if; when REM_TOKEN => null; when RENAMES_TOKEN => null; when RETURN_TOKEN => null; when REVERSE_TOKEN => null; when SELECT_TOKEN => null; -- Either entering or exiting select statement LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if (TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.END_TOKEN) then ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); end if; when SEPARATE_TOKEN => null; when SUBTYPE_TOKEN => null; when TASK_TOKEN => LOOK_AHEAD_TOKEN := SEARCH_FORWARD_FOR_ONE_OF( RESERVE_WORD_TOKEN, TOKENIZER.IS_TOKEN, -- means a block TOKENIZER.SEMICOLON); -- just spec. if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.IS_TOKEN then ENTERING_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); end if; when TERMINATE_TOKEN => null; when THEN_TOKEN => null; -- Three possibilities -- 1. AND THEN -- 2. IF <condition> THEN -- 3. ELSIF <condition> THEN -- If 1 then just count it -- If 2 then entering block structure -- If 3 then entering sub block structure -- -- check for AND THEN LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN(RESERVE_WORD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.AND_TOKEN then -- this is either if..then or elsif..then LOOK_AHEAD_TOKEN := SEARCH_BACKWARD_FOR_ONE_OF( RESERVE_WORD_TOKEN, TOKENIZER.IF_TOKEN, TOKENIZER.ELSIF_TOKEN ); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) = TOKENIZER.IF_TOKEN then ENTERING_BLOCK_STRUCTURE( RESERVE_WORD_TOKEN ); else ENTERING_SUB_BLOCK_STRUCTURE( RESERVE_WORD_TOKEN ); end if; else STYLE_REPORT.AND_THENS_USED := TRUE; end if; when TYPE_TOKEN => TYPE_DECLARATION(RESERVE_WORD_TOKEN); when USE_TOKEN => null; when WHEN_TOKEN => -- Possibilities -- 1. Variant record -- WHEN choice[|choice] => -- 2. Case statement -- same as 1 -- 3. Exception handler -- same as 1 -- 4. Guarded select -- same as 1 -- 5. EXIT [loop_name] WHEN -- EXIT loop_name WHEN-condition -- #1-4 are subblocks. Distinguished in that they should NOT -- have an identifier before the WHEN LOOK_AHEAD_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN( RESERVE_WORD_TOKEN); if TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN) /= TOKENIZER.IDENTIFIER then ENTERING_SUB_BLOCK_STRUCTURE(RESERVE_WORD_TOKEN); TOKENIZER.TOKEN_POSITION( RESERVE_WORD_TOKEN, LINE, COLUMN ); -- The elements of the 'WHEN' clause must be indented -- further than the WHEN CURRENT_STATUS.CURRENT_INDENT := COLUMN; end if; when WHILE_TOKEN => null; when WITH_TOKEN => null; -- Possibilities -- 1. WITH package[,package|procedure] -- 2. WITH subprogram spec -- (generic parameter declaration) -- If this is withing packages then it is: -- with name [,name]; NAME_TOKEN := NEXT_NON_TRIVIAL_TOKEN( RESERVE_WORD_TOKEN ); LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN( NAME_TOKEN ); SEPARATOR_TYPE := TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN); while SEPARATOR_TYPE = TOKENIZER.COMMA or SEPARATOR_TYPE = TOKENIZER.SEMICOLON loop -- Check package name if STYLE_PARAMETERS.IS_A_PROSCRIBED_PACKAGE( TOKENIZER.EXTERNAL_REPRESENTATION( NAME_TOKEN ) ) then REPORT_GENERATOR.INSERT_INTO_LIST( STYLE_REPORT.PACKAGES_PROCEDURES_WITHED, TOKENIZER.EXTERNAL_REPRESENTATION( NAME_TOKEN )); -- Add an error class for 'withed packages' REPORT_GENERATOR.PUT_FLAW( FLAWS_FILE, RESERVE_WORD_TOKEN, BAD_PACKAGE_MSG, REPORT_GENERATOR.OTHER); end if; exit when SEPARATOR_TYPE = TOKENIZER.SEMICOLON; NAME_TOKEN := NEXT_NON_TRIVIAL_TOKEN( LOOK_AHEAD_TOKEN ); LOOK_AHEAD_TOKEN := NEXT_NON_TRIVIAL_TOKEN( NAME_TOKEN ); SEPARATOR_TYPE := TOKENIZER.TYPE_OF_TOKEN_IS(LOOK_AHEAD_TOKEN); end loop; when XOR_TOKEN => STYLE_REPORT.XORS_USED := TRUE; when others => null; end case; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in RESERVE_WORD_ENCOUNTERED"); raise; end RESERVE_WORD_ENCOUNTERED; :::::::::: srchbackw.ada :::::::::: separate( STYLE_CHECKER ) function SEARCH_BACKWARD ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN is -------------------------------------------------------------------------- -- Abstract : This searches backward until it finds a given token type -- If the beginning of the list is found, the first token is -- returned as a 'failed' signal. -------------------------------------------------------------------------- -- Parameters : START_TOKEN - Where to start searching from -- GOAL_TYPE - Type to look for -------------------------------------------------------------------------- use TOKENIZER; CURRENT_TOKEN : TOKENIZER.TOKEN; begin CURRENT_TOKEN := TOKENIZER.PREVIOUS_TOKEN( START_TOKEN ); while TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= GOAL_TYPE loop CURRENT_TOKEN := TOKENIZER.PREVIOUS_TOKEN( CURRENT_TOKEN ); end loop; return CURRENT_TOKEN; exception when TOKENIZER.END_OF_TOKENS => -- and first-token call? return TOKENIZER.FIRST_TOKEN; when others => TEXT_IO.NEW_LINE; TEXT_IO.PUT("Inside SEARCH_BACKWARD -- exception:" ); TEXT_IO.PUT_LINE(CURRENT_EXCEPTION.NAME); end SEARCH_BACKWARD; :::::::::: srchbacko.ada :::::::::: separate(STYLE_CHECKER) function SEARCH_BACKWARD_FOR_ONE_OF ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE1 : TOKENIZER.TOKEN_TYPE; GOAL_TYPE2 : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN is use TOKENIZER; -------------------------------------------------------------------------- -- Abstract : This searches backward until it finds one of the token types -- If the beginning of the list is found, the first token is -- returned as a 'failed' signal. -------------------------------------------------------------------------- -- Parameters : START_TOKEN - where to start the search -- GOAL_TYPE1 - what to look for -- GOAL_TYPE2 - what else to look for -------------------------------------------------------------------------- CURRENT_TOKEN : TOKENIZER.TOKEN; SOURCE_LINE : DYN.DYN_STRING; begin CURRENT_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN( START_TOKEN ); while (TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= GOAL_TYPE1) and (TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= GOAL_TYPE2) loop CURRENT_TOKEN := PREVIOUS_NON_TRIVIAL_TOKEN( CURRENT_TOKEN ); end loop; return CURRENT_TOKEN; exception when TOKENIZER.END_OF_TOKENS => return TOKENIZER.FIRST_TOKEN; when others => TEXT_IO.NEW_LINE; TEXT_IO.PUT("Inside SEARCH_BACKWARD_FOR_ONE_OF -- exception:" ); TEXT_IO.PUT_LINE(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("While in line:"); TOKENIZER.LINE_CONTAINING_TOKEN( START_TOKEN, SOURCE_LINE ); TEXT_IO.PUT_LINE( DYN.STR( SOURCE_LINE ) ); end SEARCH_BACKWARD_FOR_ONE_OF; :::::::::: srchforwa.ada :::::::::: separate( STYLE_CHECKER ) function SEARCH_FORWARD ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN is -------------------------------------------------------------------------- -- Abstract : This searches until it finds a given token type -- If the END_OF_FILE token is found, it is returned as -- a 'fail' signal. -------------------------------------------------------------------------- -- Parameters : START_TOKEN - where to start the search -- GOAL_TYPE - what to look for -------------------------------------------------------------------------- use TOKENIZER; CURRENT_TOKEN : TOKENIZER.TOKEN; begin -- CURRENT_TOKEN := START_TOKEN; -- start the search with NEXT TOKEN! CURRENT_TOKEN := TOKENIZER.NEXT_TOKEN( START_TOKEN ); while TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= GOAL_TYPE loop if TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) = TOKENIZER.END_OF_FILE then exit; -- just return this token as a 'failed' signal. end if; CURRENT_TOKEN := TOKENIZER.NEXT_TOKEN( CURRENT_TOKEN ); end loop; return CURRENT_TOKEN; exception when others => TEXT_IO.NEW_LINE; TEXT_IO.PUT("Inside SEARCH_FORWARD -- exception:" ); TEXT_IO.PUT_LINE(CURRENT_EXCEPTION.NAME); end SEARCH_FORWARD; :::::::::: srchforeo.ada :::::::::: separate( STYLE_CHECKER ) function SEARCH_FORWARD_FOR_ONE_OF ( START_TOKEN : TOKENIZER.TOKEN; GOAL_TYPE1 : TOKENIZER.TOKEN_TYPE; GOAL_TYPE2 : TOKENIZER.TOKEN_TYPE ) return TOKENIZER.TOKEN is use TOKENIZER; -------------------------------------------------------------------------- -- Abstract : This searches FORWARD until it finds one of the token types -- If the end of the list is found, the END_OF_FILE token is -- returned as a 'failed' signal. -------------------------------------------------------------------------- -- Parameters : START_TOKEN - where to start the search -- GOAL_TYPE1 - what to look for -- GOAL_TYPE2 - what else to look for -------------------------------------------------------------------------- CURRENT_TOKEN : TOKENIZER.TOKEN; SOURCE_LINE : DYN.DYN_STRING; begin CURRENT_TOKEN := NEXT_NON_TRIVIAL_TOKEN( START_TOKEN ); while (TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= GOAL_TYPE1) and (TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) /= GOAL_TYPE2) loop if TOKENIZER.TYPE_OF_TOKEN_IS(CURRENT_TOKEN) = END_OF_FILE then exit; -- just return this token as a 'failed' signal. end if; CURRENT_TOKEN := NEXT_NON_TRIVIAL_TOKEN( CURRENT_TOKEN ); end loop; return CURRENT_TOKEN; exception when others => TEXT_IO.NEW_LINE; TEXT_IO.PUT("Inside SEARCH_FORWARD -- exception:" ); TEXT_IO.PUT_LINE(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE("While in line:"); TOKENIZER.LINE_CONTAINING_TOKEN( START_TOKEN, SOURCE_LINE ); TEXT_IO.PUT( DYN.STR( SOURCE_LINE ) ); end SEARCH_FORWARD_FOR_ONE_OF; :::::::::: typedecla.ada :::::::::: separate (STYLE_CHECKER) procedure TYPE_DECLARATION(FROM_THIS_TOKEN : in TOKENIZER.TOKEN) is procedure CHECK_FOR_ENUMERATION( AT_THIS_TOKEN : in TOKENIZER.TOKEN ) is -- ABSTRACT: Check whether this TYPE definition is an enumeration type. -- PARAMETERS: AT_THIS_TOKEN is pointing to the TYPE_TOKEN for the -- type we are going to check. -- ALGORITHM: -- The relavent cases are: -- TYPE name [Discriminant-part] ; -- incomplete type def -- TASK TYPE name IS -- TASK TYPE -- TYPE name IS ( <> ) -- generic type -- TYPE name [discriminant-part] IS ( enumeration -- -- enumeration type! -- -- I hope! use TOKENIZER; LOOKAHEAD : TOKENIZER.TOKEN; LOOKAROUND : TOKENIZER.TOKEN; begin -- find the IS to eliminate the incomplete task type LOOKAHEAD := SEARCH_FORWARD_FOR_ONE_OF(AT_THIS_TOKEN, TOKENIZER.SEMICOLON, TOKENIZER.LEFT_PARENTHESIS ); if TOKENIZER.TYPE_OF_TOKEN_IS( LOOKAHEAD ) = TOKENIZER.LEFT_PARENTHESIS then -- Inside here is NOT an incomplete type def. if TOKENIZER.TYPE_OF_TOKEN_IS(PREVIOUS_NON_TRIVIAL_TOKEN( AT_THIS_TOKEN ) ) /= TOKENIZER.TASK_TOKEN THEN -- Inside her if it is NOT a TASK TYPE if TOKENIZER.TYPE_OF_TOKEN_IS( NEXT_NON_TRIVIAL_TOKEN( LOOKAHEAD ) ) /= TOKENIZER.BOX then -- Inside here if NOT a generic type. -- This should be an enumeration type! STYLE_REPORT.DATA_STRUCTURING_TYPES_NOT_USED( REPORT_GENERATOR.ENUMERATION_TYPES) := false; end if; end if; end if; exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in CHECK_FOR_ENUMERATION"); raise; end CHECK_FOR_ENUMERATION; begin CHECK_FOR_ENUMERATION( FROM_THIS_TOKEN ); exception when others => TEXT_IO.PUT(CURRENT_EXCEPTION.NAME); TEXT_IO.PUT_LINE(" in TYPE_DECLARATION"); raise; end TYPE_DECLARATION; :::::::::: STYLE_CMP.CLI :::::::::: -- -- Compilation order for STYLE_CHECKER -- -- -- DYN (dynamic string) package (specification and body) dyn.ada -- FILE_HANDLING package specification file_spec.ada -- TOKENIZER package specification tokenizer_spec.ada -- STYLE_PARAMETERS package specification style_param_spec.ada -- REPORT_GENERATOR package specification report_gen_spec.ada -- STACK_PACKAGE package (specification and body) stack_package.ada -- two packages from spelling checker -- TOKEN_DEFINITION package (specification and body) token_definition.ada -- MANAGER package (specification and body) manager.ada -- HELP package specification help_file_spec.ada -- COMMAND_LINE_HANDLER package (specification and body) command_line.ada -- HELP_UTILITY packages HELP_SPEC.ADA HELP_BODY.ADA HELP_DIS_ALL.ADA HELP_EXIT.ADA HELP_FIND.ADA HELP_GET.ADA HELP_INIT.ADA HELP_ME.ADA HELP_MENU.ADA HELP_PROMPT.ADA HELP_RESET.ADA HELP_TEXT.ADA -- -- -- And now the bodies... -- -- HELP package body help_file_body.ada -- FILE_HANDLING package body file_body.ada -- TOKENIZER package body and all its seperate files tokenizer_body.ada insert.ada is_a_reserved_word.ada reserved_word.ada next_character.ada next_identifier.ada build_tokens.ada line_containing.ada tree_root.ada -- STYLE_PARAMETERS package body style_param_body.ada -- REPORT_GENERATOR package body report_gen_body.ada -- Main procedure (STYLE_CHECKER) and all its seperate files style_checker.ada begin_of_line_indent.ada check_statements.ada check_end_of_blocks.ada check_the_style.ada check_for_attribute.ada check_object_names.ada check_universal.ada comment_token.ada current_token.ada entering_block.ada entering_sub_block.ada exiting_block.ada get_next_token.ada is_statement.ada literal.ada new_line_token.ada non_trivial_token.ada object_name.ada reserve_word.ada search_backward.ada search_back_one_of.ada search_forward.ada search_fore_one_of.ada type_declaration.ada :::::::::: STYLE.CLI :::::::::: delete/l=???.delete.log.tmp command_line.txt write/l=command_line.txt (%1-%) x style_checker delete/l=???.delete.log.tmp command_line.txt delete ???.delete.log.tmp :::::::::: style_help.ini :::::::::: 1 HELP -- The text file used by the HELP_UTILITY Package is required to have a -- particular format. If the file is not in this format, an exception will be -- raised. The following explains the required format. -- -- COMMENTS: Comments may be embeded in the text file. All comments are ignored -- when the file is read into memory. A text line is considered a comment if -- the first and second characters of the line are minus signs ( -- ). -- -- TOPICS: The first non-comment text line MUST begin with the digit 1 in -- column one. This number is the topic level. In other words, text (as -- defined below) cannot be found in the text file before a topic is found to -- which the text can be associated. Topics are those subjects for which -- information is being provided. A topic name may contain any printable -- character except blanks. Embedded blanks are NOT allowed in a topic name. -- This will not be flagged as an error but the name will be truncated at -- the first blank. All letters in the name must be capitals. It is not -- required to have a space separating the topic level from the topic name. -- Any line beginning with a digit will be considered a topic line. -- -- SUBTOPICS: A topic may have subtopics. Subtopics are denoted by having a -- level exactly one greater than the associated topic level. Subtopics -- follow the same rules as topics in all other aspects. There is no -- constraint (other than a lack of memory) on the number of subtopic levels. -- -- TEXT: All text lines not beginning with two consecutive minus signs or a -- digit will be considered text. -- -- The text file is saved exactly as the user sees it (including blank lines) -- with the follow exceptions: -- -- o topic and subtopic names have leading blanks stripped off -- o if the topic or subtopic name is longer than one half the screen -- size, it may be truncated when a menu of information is output -- o if the text line is longer than the screen size, the text line is -- truncated before output -- o the text file lines are assumed to be eighty characters maximum. This is the Help Facility for the Style Checker. More information on specific topics may be obtained by entering the leading portion of the name of any of the topics. To get the list of topics available at any time, enter a ? at the prompt. To list the information on all topics below the current topic, enter a * at the prompt. To exit the Help Facility, enter a <CR> for each level of information. 2 INSTALLATION The original STYLE_CHECKER program was written on a Data General MV-10000 using the Data General Ada Development Environment. No features specific to the ADE were used and moving the system to another computer should be simple. The command file invoking the tool may have to be rewritten, two or three file names specific to the installation may have to be changed, and the system will have to be compiled. Moving the system should require no rewriting of the Ada source code (other than changing three internal file names). For more information on modifying the Style Checker, see the MAINTENANCE section of HELP. 3 COMPILATION The Style-Checker consists of nine packages. They are: DYN -- Dynamic strings STACK_PACKAGE -- Generic stacks COMMAND_LINE -- Get parameters from the command line HELP_PACKAGE -- Display Help Information FILE_HANDLING -- System dependencies & front-end file handling TOKENIZER -- Convert Ada to tokens STYLE_PARAMETERS -- Deliver parameters defining the style REPORT_GENERATOR -- Produce style outputs STYLE_CHECKER -- Main Procedure Some of these packages contain both specifications and bodies. Also, there are 'separate' procedures for some of the packages. Because of the dependencies, the individual files must be compiled in specific order. The order of compilation is defined in a file in the Style Checker Source directory. That file is named "COMPILE.CLI". 3 SPECIFIC_FILE_NAMES There are three hard-coded file names in the tool which may have to be modified. These three file name constants are all located in the FILE_HANDLING package. They may have to be modified to reflect where the Style Checker is installed, or to conform to the host's file-naming conventions. COMMAND_LINE_FILE_NAME -- This file will contain the parameters from the command line which invokes the tool. The default name given is COMMAND_LINE.TXT (on the MV-10000). This file will be created in the users current directory as the tool is run. SEE the HELP section on the COMMAND_FILE and on Style Checker OPERATION. This is defined in the FILE_HANDLING body, currently named: FILE_BODY.ADA HELP_FILE_NAME -- This file points to the HELP file. This file will be located in the Style Checker source directory. The current name is "STYLE_HELP.INI". This is defined in the FILE_HANDLING specifications, currently named: FILE_SPEC.ADA STYLE_DICTIONARY_NAME -- This file points to the DICTIONARY file. Currently this feature IS NOT USED. This constant exists for future expansion. The current name is "STYLE_DICTIONARY.INI". This is defined in the FILE_HANDLING specifications, currently named: FILE_SPEC.ADA 3 COMMAND_FILE A command procedure is used to invoke the Style Checker. This is written in the host's command language. Its function is to process the parameters on the command line and call the Style Checker. The command line parameters are passed to the Style Checker by putting them into a text file. Each parameter becomes a single line in the file. This file's name is predefined and corresponds to the COMMAND_LINE_FILE_NAME defined in the FILE_HANDLING package. The command procedure supplied with the Style Checker is written for the Data General command language. This file is in the Style Checker's source directory and the file is "STYLE.CLI". The parameters on the command line are the files to be style-checked. The parameters are explained more in the OPERATION section of HELP 2 OPERATION The Style Checker is invoked by the command procedure and is given parameters describing the input files. On the Data General this looks like: STYLE FILE1 FILE2 FILE3 More information on the format of the command line is below in STYLE_CHECKER_COMMAND The Style Checker will read in the set of input files. This input will be style-checked. The results will be written out as two files, a flaws file, listing individual stylistic errors, and a style report, which summarizes the style of the document. The output file names are derived from the name of the FIRST input file. 3 STYLE_CHECKER_COMMAND The command to invoke the Style Checker contains the phrase for the command procedure (on the Data General this is "STYLE") and one or more file descriptors. The file descriptor is either a file name, or a file name preceeded by a "@" character. If it is a file name, that file contains the Ada source code to be style- checked. If the file name is preceeded by a "@", then this file is a list, containing the names of other files to be style checked. This is useful when the user wishes to check a large number of files. For example, if the file "FILE_HANDLING.DIS" contains the following: COMMAND_LINE.ADA FILE_SPEC.ADA FILE_BODY.ADA <EOF> then these three files could be style checked by the following command: STYLE @FILE_HANDLING.DIS These "list" files are ordinary text files. They can contain nested references to other "list" files. This can be nested up to 10 levels deep. An example of this can be seen as the following file: @FILE_HANDLING.DIS DYN.ADA @TOKENIZER HELP.ADA STACK.ADA @REPORT_GEN.DIS @STYLE_PARAM.DIS @STYLE_CHECKER.DIS <EOF> If the above were used as input to the Style Checker, it would check the three files and the other files listed in the five "list" files. 3 INPUT_FILES The input to the Style Checker is a set of input files which are concatenated together and treated as if they were one input file. The input is expected to be syntactically correct Ada. If the input is not correct Ada, the Style Checker will in many cases be able to check the input anyway, but this may cause erroneous results. There are some cases where incorrect Ada input will cause the Style Checker to malfunction. A major example of this is the nesting of blocks. If the input program contains too many "END" statements, the Style Checker currently is unable to recover and will usually fail, producing only a partial "flaws" list and no "report" output. Because of this, it is best to be sure the input is correct Ada before trying to check its style. 3 OUTPUT_FILES The Style Checker produces two output files. The names of these files are derived from the first real input file (not from the "list" files). The file name extension is stripped from the input file name. The extension "FLW" is added to create the "flaws" file name. The extension "STY" is added to create the "report" file name. EXAMPLE: If the Style Checker were invoked by: STYLE TEST1.ADA COPYFILE.ADA ANOTHER.ADA then the output file names would be: TEST1.FLW, and TEST1.STY. Examples of "flaws" and "report" files can be found in the Style Checker Testing directory. For each test file, there will be a "flaw" file and a "report" file. 4 FLAWS_FILE The "flaws" file contains notices of individual style mistakes. Each notice includes the style "flaw" which was found, and a copy of the source line in which the flaw was located. Discussions of the individual flaws reported can be found under the discussion of INDIVIDUAL_PARAMETERS in HELP. OUTPUT DISCREPANCIES: Be aware that the output of flaws is generated when the flaw is discovered. This may not be when the line is first parsed. For example, the size of loops, or procedures is not known until the end of the loop or procedure, so the flaws file will contain output flaws from the middle of the loop, and then later show the start of the loop and say that this loop is too large. Statements which span lines will not be completely be printed when a flaw is reported. The Style Checker trys to print the line containing the erroneous part of the statement, but it does not always succeed. If one particular error occurs too many times, it would be repetitive to continue listing that error. Accordingly, there is a parameter, "ERRORS_TO_LIST", which puts a limit on how many times an individual error is output. The default setting is 5. This means that if the input contained many indentation errors, only the first 5 would be noted in the flaws file. The other indentation errors would still be included as part of the style report file. 4 REPORT_FILE The "report" file contains a summary of the style problems encountered in the source. This is a combined summary for the total input. If reports are desired for individual files, they will have to be style-checked separately. The style report indicates A. Counts of flaws B. Limits exceeded -- this is typically the average of some check mode over the entire input, such as average length of names. C. Notes of other style issues -- this may be notes that the input does not show use of some Ada feature such as enumeration types. If the line is showing a style error, then the line is flagged by putting a "*" before the line. If the line contains minor problems, or nothing is wrong, but the user might be able to improve, the line is flagged with a "!". The individual sections of the style report are in subsections below. These describe the meaning of the information. The actual results depend on the definition of the style parameters. For more information on the actual style checked, see the HELP section on INDIVIDUAL_PARAMETERS. 5 NAMING_CONVENTIONS Example: >------------------------------------------------------------------------- > * Invalid Case for an Object Identifier 133 Errors > * Invalid Case for a Keyword 3 Errors > Name Segment Size (Separated Desired <5 Characters > by Underscores) Actual 4.1 Characters > Average Name Size Desired >5 Characters > Actual 15.5 Characters >------------------------------------------------------------------------- This section deals with words. The instances of names being typed in the wrong case are shown. Also shown is the average length of names, and a measurement showing whether enough underscores are used. See Help information on INDIVIDUAL_PARAMETERS for explanations of the following: SHORT_WORD RESERVED_CASE OBJECT_CASE AVE_NAME_LEN UNDERSCORES UNDERSCORE_SIZE 5 PHYSICAL_LAYOUT >------------------------------------------------------------------------- > * Occurrences of More Than One Statement/Line 51 Errors > * Inconsistant Indentation 596 Errors > * Missing Blank Lines to Set Off a Block 113 Errors > * Loops Without Names 12 >------------------------------------------------------------------------- This section relates to readability. Most of these are self-explanatory. Note that structures (packages, loops, etc.) may be required to have blank lines surrounding them, and loops should have loop-names. These are only required when the given structure is larger than a limit defined in the style. See Help information on INDIVIDUAL_PARAMETERS for explanations of the following: SMALL_STRUCTURE STATEMENT_LINE INDENT_TYPES INDENT_COMMENTS BLANK_LINES LOOP_NAMES 5 INFORMATION_HIDING >------------------------------------------------------------------------- > Percent of Literals In Body Desired < 10.0% > * Actual 79.7% > Percent of Universal Types Desired < 40.0% > Actual 20.0% > ! Data Structuring Types NOT Used > Array Types > Enumeration Types > Record Types > ! No Attributes are Used > ! Ada-Specific Features NOT used > AND THEN > OR ELSE > EXITS > XOR > ELSIF > EXCEPTION > IN parameters > OUT parameters > IN OUT parameters >------------------------------------------------------------------------- This measures the number of literals (both string and numeric) in the body with respect to those in the declaration sections. Also the percentage of universal type (integer, etc.) compared to other type is measured. The use of data structuring types and Ada-specific features is also detected. The next line indicates that the input uses no attributes. The "!" shows that the user might profit by learning more about these features. See Help information on INDIVIDUAL_PARAMETERS for explanations on the following: PERCENT_LITERALS PERCENT_UNIVERSALS ATTRIBUTE_CHECK DATA_STRUCTURES 5 MODULARITY >------------------------------------------------------------------------- > Average Number of Parameters Range 1..8 Parameters > * Instances of parameters below minimum 6 > Instances of parameters above maximum 0 > Average Subprogram Size Range 10..200 Statements > * Instances of size below minimum 6 > * Instances of size above maximum 2 > Loops with too many exit statements 0 Instances > Control Structure Nesting Maximum 8 > Exceeded 0 Instances > Package Nesting Maximum 2 > Exceeded 0 Instances > Subprogram Nesting Maximum 4 > Exceeded 0 Instances >------------------------------------------------------------------------- Size and nesting are used as measurements of modularity. There are limits on the size of subprograms, and on how many parameters they have. There is a limit on the number of exits a loop may have. The last six lines show the nesting of the input. See Help information on INDIVIDUAL_PARAMETERS for explanations on the following : SUBPROGRAM_SIZE SUBPROGRAM_PARAMETERS NUMBER_OF_LOOP_EXITS CONTROL_NESTING PACKAGE_NESTING SUBPROGRAM_NESTING 5 COMMENT_USAGE >------------------------------------------------------------------------- > Number of Comments 606 Comments > Average Comment Size Desired >15 Characters > Actual 38.8 Characters >------------------------------------------------------------------------- The comment size is recorded so that the program cannot be fooled by simply adding a large number of blank comments. See Help information on INDIVIDUAL_PARAMETERS for COMMENT_SIZE explanation. 5 TRANSPORTABILITY >------------------------------------------------------------------------- > * Number of Lines Exceeding Line Length 69 > Address Clauses 0 > Representation Specifications 0 > PRAGMA'S used: > INLINE > Non-Standard PRAGMA's Used > MAIN > Packages/Procedures WITHed > CURRENT_EXCEPTION >------------------------------------------------------------------------- This notes features which may be untransportable. "Pragma's used" lists pragmas defined in the LRM. "Non-Standard pragma's" lists other pragmas. "Packages withed" lists any packages in the input which are defined in the style as "proscribed" packages. This typically includes non-transportable packages such as SYSTEM, UNCHECKED_CONVERSION, etc. This section might also show the presence of any characters which are not in the allowable set defined in the style. The final item is a notice describing the use of Ada features which are not available in other languages. This is intended to provide information for the user to see what could be learned to improve their programs. See Help information on INDIVIDUAL_PARAMETERS for explanations on the following: LINE_SIZE REPRESENTATION_SPECS ADDRESS_CLAUSE PRAGMAS PREDEFINED_PRAGMA PROSCRIBED_PACKAGE CHARACTER_SET 5 KEYWORD_USAGE >Used Keyword Allowed Restriction Occurrences Percentage >------------------------------------------------------------------------- > AT yes 0.0% 0 0.0% > DO yes 0.0% 0 0.0% > IF yes 0.0% 258 13.5% > IN yes 0.0% 74 3.9% . . . > GOTO yes 5.0% 0 0.0% > LOOP yes 0.0% 60 3.1% >-------------------------------------------------------------------------- This optional list shows the Ada reserved words, whether the style allows their use, and how often they were used in the input. See Help on INDIVIDUAL_PARAMETERS for KEYWORD_PARAMETERS explanation. 2 INDIVIDUAL_PARAMETERS The parameters defining the limits of the Ada style are defined in the body of the FILE_HANDLING package. In that body the default values are specified as defaults for the individual parameter variables. There is also a procedure SET_STYLE_PARAMETERS which sets the actual values for the style. It is expected that any local changes to the style parameters will be done in the SET_STYLE_PARAMETERS procedure, so that the original defaults remain unchanged. 3 ERRORS_TO_LIST To avoid redundantly repeating instances of detected errors, the ' errors-to-list' parameter restricts the number of times any one error is listed. This means, for example, only the first 5 times the user forgot to use loop-names would be listed. Other occurences of each individual error would be counted, and the total instances of the error would be noted on the style summary. 3 OUTPUT_KEYWORD_LIST To shorten the output, the Style Checker may be set to not print the complete summary of reserved words used. The options are: ALL_KEYS Print all keywords USED Print only those keywords which are used NOT_USED Print only those keywords which are not used ERRORS Print those keywords whose usage is in error NONE Do not print keywords 3 SHORT_PROGRAM The Short-Program parameter measures the size of subprograms which are too small to be considered significant for some measures. The parameter is an integer, N, where programs less than N statements are 'short'. Short programs may not contain enough information to make valid judgements on whether 'restricted' reserved words are used too often. These measurements will still be made, but the user should be aware that they not be significant. 3 SHORT_WORD The Short-Word parameter defines the size, in characters, of 'small' words. Words this small or smaller are detected as too small to effectively identify the object's contents. In addition, words this short will not be checked for the presence of underscores, or checked for abbreviations. 3 SHORT_STRUCTURE Some sections of code are too short to be reasonably checked. For example, loop names may be required on control structures, but it is not reasonable to require them on very short loops (such as a 1-statement loop). Anything which has 'short-structure' statements or less is small and doesn't have to be checked for loop-names, blank lines around the loop, etc. 3 RESERVED_CASE Reserved-Case is an enumeration object indicating the defined style of presenting reserved words as all capitals, all lower case, or mixed cases. The values are: * ReservedCaseUpper: Reserved words must be upper case. * ReservedCaseLower: Reserved words must be lower case. * ReservedCaseConsistant: Reserved word case is determined by the case of the FIRST reserved word encountered. All subsequent words must be the same case. * ReservedCaseAny: Reserved words do not have to follow any convention. 3 OBJECT_CASE Object-Case is an enumeration object indicating the defined style of presenting names as all capitals, all lower case, or mixed cases. The values are: * NameCaseUpper: Names must be upper case. * NameCaseLower: Names must be lower case. * NameCaseFirstCapitalized: The first letter of names must be capitalized. The name may contain other capitalized letters such as when a name is the concatenation of several words like: LinesOfCode or GeometricMean. * NameCaseConsistant: Name case is determined by the case of the FIRST name encountered. All subsequent words must be the same case. * NameCaseAny: Names do not have to follow any convention. 3 AVE_NAME_LEN This parameter is a positive integer used to judge whether the user is replying on too many small names. If the average length of names over the whole program is less than this value, then a style flaw has occured. The user is told he is using too many short names. 3 UNDERSCORES This is a flag indicating whether underscores should be checked for. On some computers or for some systems underscores may not be a desirable feature. If the flag is TRUE, the presence and frequency of underscores will be checked as detailed in the HELP on underscore-size. If the flag is FALSE, underscores will be ignored. Note that FALSE does not mean that underscores are incorrect. 3 UNDERSCORE_SIZE If underscores are required, the style checker will check the average number of characters not separated by underscores in a program. If the resultant average is greater then underscore-size, the user has too few underscores in his names. The specific method of checking this is as follows: A. If the name is short (less than or equal to 'small-word' characters) it is ignored. B. Count the characters in each segment of the name, where segments are separated by underscores. C. Average these counts over the whole program. D. If the program average is greater than underscore-size, an error report is made. 3 VOWEL_FREQUENCY While abbreviations save typing time, it is easy to abbreviate too much, and for maintenance programmers, who are not at all familiar with a program, any abbreviations are confusing. The heuristic used to try to detect abbreviations is the percentage of vowels WRT consonants in the names. Since the common forms of abbreviation involve striping out the vowels, if the names have too few vowels, the programmer is probably abbreviating. The program calculates the percentage of vowels versus the total number of letters in the word. These percentages are averaged over the entire program and if this percentage is under the 'Vowel-Frequency' parameter, a style flaw is noted. 3 SPELLING_REQUIRED This function is currently only existant as a stub. It is eventually intended to check individual name segments of words against a project dictionary to see if the words used are allowable. 3 INDENT_TYPES This is a flag indicating whether to check for consistant indenting in the declaration portions of a program. If TRUE, the style checker will note inconsistant indentation in the declarations as a style flaw. 3 INDENT_COMMENTS This is a flag indicating whether to check for consistant indenting in the comments which follow statements on the same line. NULL; -- This is a trailing comment If TRUE, the style checker will note inconsistant indentation in the trailing comments as a style flaw. 3 BLANK_LINES To physically separate control structure on the listing, the style may require blank lines to be placed around control structures. If this parameter is TRUE, the absence of blank lines around control structures will be noted as a style flaw. For example: NULL; -- Previous statement LOOP -- Blank line before and after NULL; -- this loop END LOOP; NULL; -- Next statement(s) 3 LOOP_NAMES To help locate the beginning and end of structures, the style may require loop names at the start and end. These names are required if the parameter is TRUE. 3 COMMENT_SIZE To prevent coders from entering empty comments to fool the style checker, the average size of comments (in characters) over the whole program must be greater than 'comment-size' or a style flaw will be noted. 3 PERCENT_LITERALS The use of literal values such as numeric constants or strings in the body of a program significantly reduces the maintainability of the program. Literals should preferably be in the declaration to give them greater visibility and modifiability. This parameter is the maximum allowable amount of literals allowed in the program bodies. The number is the percentage of literals in the bodies compared to all literals in the program. If the program's percentage of literals in the bodies is greater than 'percent-literals', then a style flaw is noted. 3 PERCENT_UNIVERSAL Programmers which are used to restricted data typing such as Fortran's integer and real, may not initially use the freedom to create types which Ada allows. In addition, some programmers may only use the universal types (integer) out of laziness. To discourage the exclusive use of universal types, the style can check the percentage of universal types used as compared to other user-defined numeric types. If the average percentage of universal types is greater than 'percent-universal', a style flaw will be noted. 3 DATA_STRUCTURES Programmers use to more primitive languages such as Fortran or assembler may not have learned to use the data structuring facilities of Ada such as records or enumeration types. If the 'data-structures' flag is TRUE, the style checker will note whether these data structuring facilities are used in the program. If they are not used, a the style report will note that fact and suggest the programmer investigate Ada's data structuring abilities. 3 ATTRIBUTE_CHECK The use of attributes is important for such purposes as limiting the number of constants in the program. The style definition includes a parameter which tells the style checker to detect the use of attributes in the input. If the input contains NO attributes, a flag is raised indicating potential for improvement by learning the use of attributes. 3 SUBPROGRAM_SIZE The size of a subprogram directly impacts its understandability and maintainability. The style will define limits on a subprogram's size, both large and small. This parameter is two numbers limiting the size, in statements of a subprogram. If these limits are violated, a style flaw is noted. 3 SUBPROGRAM_PARAMETERS The number of parameters to a subprogram impacts its modularity. The style defines limits on the number of parameters. These are both maximum and minimum limits. The applicable function will return two numbers giving the limits for parameters. If limits are violated, a style flaw is noted. 3 CONTROL_NESTING If programs are nested too deeply this may indicate improper modularity. This parameter indicates that nesting of control structures too deeply be flagged as a style flaw. 3 PACKAGE_NESTING If programs are nested too deeply this may indicate improper modularity. This parameter indicates that nesting of packages too deeply be flagged as a style flaw. 3 SUBPROGRAM_NESTING If programs are nested too deeply this may indicate improper modularity. This parameter indicates that nesting of subprograms too deeply be flagged as a style flaw. 3 NUMBER_OF_LOOP_EXITS Structured programming limits the possible exits from a structure. This parameter defines the limit on the number of exits. If a loop has more exit statements than defined by this parameter, a style flaw is noted. 3 LINE_SIZE In transporting a program to a different machine, the new machine may impose different limits on the size of lines. This parameter allows the style to flag lines which are longer than a certain size. In this way, those line which might have to be changed for transportability can be easily found. 3 CHARACTER_SET The LRM defines two different classes of characters. The BASIC characters are those required to be processable by any Ada system. The GRAPHIC characters are the additional normal characters which are usually available. Since some machines may not support all characters, the style checker will note special characters which may have to be changed for transportability. This can also catch non-printing character which have inadvertently gotten into the source. The character classes allowed are (see LRM for complete definition): BASIC -- Upper case letters, 0..9, punctuation GRAPHIC -- Lower case letters, special punctuation: ! $ % ? @ [ \ ] ^ ` { } ~ EXTENDED -- Other non-graphic ASCII characters, <ESC>, etc. 3 REPRESENTATION_SPECS Representation specifications are very non-transportable features in Ada. The Style Checker can be told by this parameter to locate and flag uses of representation specifications. If this parameter is FALSE then representation specifications are not allowed and are flagged as flaws. 3 ADDRESS_CLAUSE Address clauses are very non-transportable features in Ada. The Style Checker can be told by this parameter to locate and flag uses of address clauses. If this parameter is FALSE then address clauses are not allowed and are flagged as flaws. 3 PRAGMAS Pragmas may be compiler-dependant parts of a system. This parameter tells whether to flag occurrences of pragmas in the input. The possible values may be: ALL -- flag all pragmas SYSTEM-DEPENDENT -- flag pragmas not defined in the LRM NONE -- do not flag pragmas 3 PREDEFINED_PRAGMA This is not a parameter, but is a definition of which pragmas are defined in the LRM. This is a function called which returns TRUE if the input pragma-name is defined in the LRM. There are 14 predefined pragmas. 3 PROSCRIBED_PACKAGE The use of some packages depend highly on the supporting host. These packages may make transporting a system difficult. The Style Checker can be provided with a list of the packages which the user wants flagged. These packages are called PROSCRIBED PACKAGES. Typical packages might include UNCHECKED_CONVERSION, and SYSTEM. These packages are defined by an array of strings naming the proscribed packages. The array is PROSCRIBED. This is a special parameter in that its value must be changed in the default definition of the parameter. All other parameters are changed in the SET_STYLE_PARAMETERS procedure. 3 KEYWORD_PARAMETERS The use of each Ada reserved word may be limited for style purposes. Each reserved word is specified separately. The usage classes are * Prohibited: Any use at all is a style flaw. * Restricted: This requires a second, numeric parameter which is the maximum allowed frequency of the reserved word. The number is the percentage of statements which may contain the reserved word. For example, if the number is 0.05 then the reserved word cannot appear more than five times per 100 statements. * Unlimited: The reserved word can be used freely. 2 STYLE_ISSUES_IN_GENERAL This tool has been designed to provide a level of style checking to give the user confidence that his system is following good guidelines. Since few programmers agree completely on the correct way to structure code, much of the style checking is dependent on a set of style parameters delivered by the STYLE_PARAMETERS package. These parameters are changable by altering values in the body of that package. For instructions on altering the style values, see CHANGING_STYLE_PARAMETERS, below. It should be noted that because of the wide variety in possible styles, some compromises had to be made. For example, checking indentation of comments has basically been eliminated since so many people use different styles. There are a few areas where it is possible to violate the "correct style" and this program will not catch the error. Usually this is the case so that other correct style instances will not be caught along with the bad. 3 CHANGING_STYLE_PARAMETERS Inside the STYLE_PARAMETERS package, the values of the parameters are defined in two different places. In the declarations for the BODY, the default values are set. These default values should not be changed so as to provide a standard basic style. (There is one exception noted below.) The actual values are set in the SET_STYLE_PARAMETERS procedure which is called in the STYLE_PARAMETERS body. This is where new style parameter values should be changed. Most of the possible values are obvious, such as POSITIVE or BOOLEAN values. There are a few special enumeration types used. These types are defined in the STYLE_PARAMETERS specification. Exception: The only style parameter which should be changed in the declarations rather than in the SET_STYLE_PARAMETERS procedure is the PROSCRIBED variable, defining those packages which are to be flagged as undesirable packages. This should be changed in the declaration itself. 2 MAINTENANCE For maintenance information look under the HELP file for INSTALLATION instructions, or look at the MAINTENANCE manual in the documentation directory