Programmer's ROM - The Computer Language Library

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

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

Wrap

Text File | 1988-05-03 | 1007.0 KB | 29,927 lines

:::::::::::::: block_u.bdy :::::::::::::: --VMS file: %nosc.work.tools.halstead.source*(block_u.bdy) --UTS file: /nosccomp/byron/_vms//nosc/work/tools/halstead/COMP/block_u.bdy -- $Source: /nosc/work/tools/halstead/RCS/block_u.bdy,v $ -- $Revision: 1.2 $ -- $Date: 86/02/04 22:05:46 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.2 $"); with ML_Source_Position_Pkg; package body Block_Utilities is package MLSP renames ML_Source_Position_Pkg; -------------------------------------------------------------------------- -- LOCAL SUBPROGRAMS -------------------------------------------------------------------------- function Is_Source_Position_Null ( Position :in MLSP.Source_Position ) return boolean; --| OVERVIEW --| This procedure returns true if the source position passed in --| is null. This means that column and line of the --| Position.first_location is 0. -------------------------------------------------------------------------- function In_Declare_Block ( --| This function determines whether --| we are in a block with declarations. --| If we are it returns true otherwise --| false. block :in BLOCK_STUB.Locator ) return boolean is use SeqOfITEM; I :Generator; begin --| OVERVIEW --| This function is used to determined if in fact the block --| passed in is a block with explicit declarations which --| means the token declare appears in the source program. --| This is determined by walking down the list of declarations --| until something which is not an implicit label is encountered. --| Implicit labels are inserted in the as_item_s list --| of the enclosing block. Thus if the only elements of the --| as_item_s of the block are implicit_labels then the token --| declare does not appear in the source program. StartForward (as_item_s (block), I); while not Finished(I) loop case Kind (Cell (I)) is when implicit_label_declKind => Forward (I); when others => EndIterate (I); return true; end case; end loop; EndIterate (I); return false; end In_declare_block; -------------------------------------------------------------------------- function Is_Block_Labeled ( --| This function returns true --| if the block passed in has a label --| and returns false otherwise. block :in block_stmNode.Locator ) return boolean is begin return not Is_Source_Position_Null ( lx_srcpos (as_block_label (block)) ); end; -------------------------------------------------------------------------- function Is_Source_Position_Null ( Position :in MLSP.Source_Position ) return boolean is begin return MLSP."=" (Position.first_location,0); end; end Block_Utilities; :::::::::::::: block_u.spc :::::::::::::: --VMS file: %nosc.work.tools.halstead.source*(block_u.spc) --UTS file: /nosccomp/byron/_vms//nosc/work/tools/halstead/COMP/block_u.spc -- $Source: /nosc/work/tools/halstead/RCS/block_u.spc,v $ -- $Revision: 1.2 $ -- $Date: 86/02/04 22:05:09 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.2 $"); with ST_DIANA; use ST_DIANA; package Block_Utilities is -------------------------------------------------------------------------- function In_Declare_Block ( --| This function determines whether --| we are in a block with declarations. --| If we are it returns true otherwise --| false. block :in BLOCK_STUB.Locator ) return boolean; function Is_Block_Labeled ( --| This function returns true --| if the block passed in has a label --| and returns false otherwise. block :in block_stmNode.Locator ) return boolean; end Block_Utilities; :::::::::::::: comlin.bdy :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/comlin.bdy,v $ -- $Revision: 1.18 $ -- $Date: 85/03/25 21:03:22 $ -- $Author: buddy $ with Text_IO; use Text_IO; with Int_IO; use Int_IO; package body CommandLine is TokenSeparator :constant character := '%'; -------------------------------------------------------------------------- procedure ScanForChar ( S :in String; C :in character; Start :in positive; Place : out natural ) is Temp :positive := Start; Found :boolean := false; begin Place := 0; while (Temp <= S'Last) and (not Found) loop if S(Temp) = C then Place := Temp; Found := true; end if; Temp := Temp + 1; end loop; end; -------------------------------------------------------------------------- function GetNumberOfUnits( S :in String ) return natural is count :natural := 0; begin for i in S'Range loop if S(i) = TokenSeparator then count := count + 1; end if; end loop; return count; end; -------------------------------------------------------------------------- function GetToken ( S :in String; Start :in positive ) return String is EndOfToken :natural; begin ScanForChar (S, TokenSeparator, Start, EndOfToken); if EndOfToken = 0 then raise TokenNotFound; else return S(Start..EndOfToken - 1); end if; end; -------------------------------------------------------------------------- procedure Advance ( S :in String; Start :in out positive ) is begin Start := Start + GetToken (S, Start)'Length + 1; end; -------------------------------------------------------------------------- function GetSpec ( S :in String; Start :in positive ) return boolean is begin if boolean'Value (GetToken (S, Start)) in false..true then return boolean'Value (GetToken (S, Start)); end if; exception when CONSTRAINT_ERROR => raise ExpectingBoolean; end; -------------------------------------------------------------------------- function IsSubUnit ( S :in String; Start :in positive ) return boolean is PeriodPosition :natural; begin ScanForChar (S, '.', Start, PeriodPosition); if (S'First < PeriodPosition) and (PeriodPosition < S'Last) then return true; else return false; end if; end; -------------------------------------------------------------------------- function GetParent ( S :in String; Start :in positive ) return String is PeriodPosition :natural; begin ScanForChar (S, '.', Start, PeriodPosition); if PeriodPosition = 0 then raise InvalidSubUnit; else Return S(Start..PeriodPosition - 1); end if; end; -------------------------------------------------------------------------- function GetSubUnit ( S :in String; Start :in positive ) return String is PeriodPosition :natural; EndToken :natural; begin ScanForChar (S, '.', Start, PeriodPosition); ScanForChar (S, TokenSeparator, PeriodPosition, EndToken); if EndToken = 0 then raise InvalidSubUnit; else return S(PeriodPosition + 1..EndToken - 1); end if; end; -------------------------------------------------------------------------- end CommandLine; :::::::::::::: comlin.spc :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/comlin.spc,v $ -- $Revision: 1.5 $ -- $Date: 85/03/24 16:17:23 $ -- $Author: buddy $ package CommandLine is TokenNotFound :exception; ExpectingBoolean :exception; InvalidSubUnit :exception; function GetNumberOfUnits( S :in String ) return natural; -------------------------------------------------------------------------- procedure Advance ( S :in String; Start :in out positive ); -------------------------------------------------------------------------- function GetToken ( S :in String; Start :in positive ) return String; -------------------------------------------------------------------------- function IsSubUnit ( S :in String; Start :in positive ) return boolean; -------------------------------------------------------------------------- function GetParent ( S :in String; Start :in positive ) return String; -------------------------------------------------------------------------- function GetSpec ( S :in String; Start :in positive ) return boolean; -------------------------------------------------------------------------- function GetSubUnit ( S :in String; Start :in positive ) return String; -------------------------------------------------------------------------- end CommandLine; :::::::::::::: count.bdy :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/count5.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/12/31 14:51:21 $ -- $Author: maria $ --pragma revision ("$Revision: 1.1 $"); -- $Source: /nosc/work/tools/halstead/RCS/count5.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/12/31 14:51:21 $ -- $Author: maria $ --pragma revision ("$Revision: 1.1 $"); -- $Source: /nosc/work/tools/halstead/RCS/count5.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/12/31 14:51:21 $ -- $Author: maria $ --pragma revision ("$Revision: 1.1 $"); -- $Source: /nosc/work/tools/halstead/RCS/count5.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/12/31 14:51:21 $ -- $Author: maria $ --pragma revision ("$Revision: 1.1 $"); with Text_IO; use Text_IO; with Int_IO; use Int_IO; package body count is TokenClassification: array (D.TokenItem) of D.Class := ( D.abortz => D.operator, D.acceptz => D.operator, D.accessz => D.operator, D.allz => D.operator, D.and_thenz => D.operator, D.arrayz => D.operator, D.atz => D.neither, D.beginz => D.neither, D.bodyz => D.neither, D.body_packagez => D.neither, D.body_taskz => D.neither, D.casez => D.neither, D.case_stmz => D.neither, D.case_variantz => D.neither, D.constantz => D.operator, D.declarez => D.operator, D.delayz => D.operator, D.deltaz => D.operator, D.digitsz => D.operator, D.doz => D.neither, D.elsez => D.operator, D.else_ifz => D.operator, D.else_orz => D.operator, D.else_selectz => D.operator, D.elsifz => D.operator, D.endz => D.neither, D.end_acceptz => D.neither, D.end_beginz => D.neither, D.end_case_stmz => D.operator, D.end_case_variantz => D.operator, D.end_ifz => D.operator, D.end_loopz => D.operator, D.end_package_bdyz => D.operator, D.end_package_spcz => D.operator, D.end_recordz => D.operator, D.end_record_repz => D.operator, D.end_selectz => D.operator, D.end_task_spcz => D.operator, D.entryz => D.operator, D.exceptionz => D.operator, D.exitz => D.operator, D.forz => D.neither, D.for_loopz => D.neither, D.for_repz => D.neither, D.functionz => D.operator, D.genericz => D.operator, D.gotoz => D.operator, D.ifz => D.neither, D.inz => D.operator, D.in_loopz => D.operator, D.in_membershipz => D.operator, D.in_out_parameterz => D.neither, D.in_parameterz => D.neither, D.isz => D.neither, D.is_case_stmz => D.neither, D.is_case_variantz => D.neither, D.is_functionz => D.neither, D.is_genericz => D.neither, D.is_package_bdyz => D.neither, D.is_package_spcz => D.neither, D.is_procedurez => D.neither, D.is_separatez => D.operator, D.is_subtypez => D.neither, D.is_typez => D.neither, D.is_task_bdyz => D.neither, D.is_task_spcz => D.neither, D.limitedz => D.operator, D.loopz => D.neither, D.modz => D.operator, D.newz => D.neither, D.new_allocatorz => D.operator, D.new_derived_typez => D.operator, D.new_generic_instz => D.operator, D.not_in_membershipz => D.operator, D.nullz => D.neither, D.null_valuez => D.operand, D.null_stmz => D.operator, D.null_fieldz => D.operator, D.ofz => D.operator, D.orz => D.operator, D.or_elsez => D.operator, D.or_selectz => D.operator, D.othersz => D.neither, D.others_aggregatez => D.operator, D.others_casez => D.operator, D.others_exceptionz => D.operator, D.others_variantz => D.operator, D.outz => D.neither, D.packagez => D.neither, D.package_bdyz => D.neither, D.package_spcz => D.neither, D.pragmaz => D.operator, D.privatez => D.neither, D.private_sectionz => D.operator, D.private_typez => D.operator, D.procedurez => D.neither, D.raisez => D.operator, D.rangez => D.operator, D.recordz => D.neither, D.record_typez => D.neither, D.record_repz => D.neither, D.renamesz => D.operator, D.returnz => D.operator, D.reversez => D.operator, D.selectz => D.neither, D.separatez => D.neither, D.subtypez => D.operator, D.taskz => D.neither, D.task_bdyz => D.neither, D.task_spcz => D.neither, D.terminatez => D.operator, D.thenz => D.neither, D.then_andz => D.operator, D.typez => D.operator, D.usez => D.neither, D.use_contextz => D.operator, D.use_repz => D.operator, D.whenz => D.neither, D.when_case_stmz => D.neither, D.when_exitz => D.neither, D.when_exceptionz => D.neither, D.when_selectz => D.neither, D.when_case_variantz => D.neither, D.whilez => D.operator, D.withz => D.neither, D.with_contextz => D.operator, D.with_genericz => D.operator, ------------- punctuation -------------- D.arrowz => D.operator, D.barz => D.operator, D.boxz => D.neither, D.box_rangez => D.operator, D.box_default_subpz => D.operator, D.character_literalz => D.operand, D.closed_anglesz => D.neither, D.closed_parenthesisz => D.neither, D.colon_equalsz => D.operator, D.colonz => D.operator, D.commaz => D.operator, D.dotz => D.operator, D.dot_dot_rangez => D.operator, D.double_quotez => D.operand, D.numeric_literalz => D.operand, D.open_anglesz => D.operator, D.open_parenthesisz => D.operator, D.semicolonz => D.neither, D.single_quotez => D.neither, D.tickz => D.operator, D.declare_blockz => D.neither ); --| This is a map from token types to symbol classification. --| It indicates which class (D.operator, operand, neither) --| a token is in. -------------------------------------------------------------------------- function RemoveLastChar ( --| This removes the last character from --| the string S. This is used to get --| rid of the z's in the TokenItems. S :in String ) return String is begin return S(S'first..S'last - 1); end; -------------------------------------------------------------------------- procedure HalsteadCount ( TokenInfo :in D.TokenCountType; VerboseOn :in boolean; Nn: in out CT.NnInfoType ) is begin for t in D.TokenItem loop if TokenInfo(t) > 0 then Nn(TokenClassification(t)).Vocabulary := Nn(TokenClassification(t)).Vocabulary + 1; Nn(TokenClassification(t)).Usage := Nn(TokenClassification(t)).Usage + TokenInfo(t); if VerboseOn then Put (Standard_Output, "number of "); Put (Standard_Output, RemoveLastChar (D.TokenItem ' image (t))); Put (Standard_Output, " tokens is "); Put (Standard_Output, TokenInfo(t)); New_Line (Standard_Output); end if; end if; end loop; end HalsteadCount; end count; :::::::::::::: count.spc :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/count.spc,v $ -- $Revision: 1.3 $ -- $Date: 85/06/13 13:29:12 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.3 $"); with Definitions; with Count_Types; package Count is package D renames Definitions; package CT renames Count_Types; -------------------------------------------------------------------------- procedure HalsteadCount ( --| This procedure determines which tokens --| are operators and operands and counts --| them. TokenInfo :in D.TokenCountType; VerboseOn :in boolean; Nn: in out CT.NnInfoType ); -------------------------------------------------------------------------- end Count; :::::::::::::: countype.bdy :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/countype.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/07/04 11:38:21 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.1 $"); -- $Source: /nosc/work/tools/halstead/RCS/countype.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/07/04 11:38:21 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.1 $"); with Definitions; package body Count_Types is -------------------------------------------------------------------------- function AddCounts ( --| This function Adds two records and --| returns their sum. L :in NnInfoType; R :in NnInfoType ) return NnInfoType is Sum :NnInfoType; begin for c in Definitions.Class loop Sum(c).Vocabulary := L(c).Vocabulary + R(c).Vocabulary; Sum(c).Usage := L(c).Usage + R(c).Usage; end loop; return Sum; end; -------------------------------------------------------------------------- procedure ZeroCount (--| Sets the counts of all the classes of NnInfo --| to 0. NnInfo :in out NnInfoType ) is begin for c in Definitions.Class loop NnInfo(c).Vocabulary := 0; NnInfo(c).Usage := 0; end loop; end; ------------------------------------------------------------------------- - end Count_Types; :::::::::::::: countype.spc :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/countype.spc,v $ -- $Revision: 1.1 $ -- $Date: 85/07/04 11:36:37 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.1 $"); -- $Source: /nosc/work/tools/halstead/RCS/countype.spc,v $ -- $Revision: 1.1 $ -- $Date: 85/07/04 11:36:37 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.1 $"); with Definitions; package Count_Types is --| OVERVIEW --| This package defines types that are being used in the counting --| of tokens. It also provides an operation AddCounts which --| a function which returns the sum of two NnInfoType records. --| This is needed because it is necessary to separate the token --| counts which result from DEF_ID_Analysis and Literal_Analysis --| and the token counts which result from keyword other syntactic --| constructs. type NnRecordType is record Vocabulary: natural := 0; Usage: natural := 0; end record; --| This package is used to define the NnInfoType used by all --| the different counting strategies. type NnInfoType is array (Definitions.Class) of NnRecordType; --| NnInfoType keeps track of the vocabulary and usage for each --| class (i.e. operator, operand, and neither). --| --| Vocabulary keeps track of the number of unique symbols in --| the source program. For example: --| --| Nn :NnInfoType; --| --| Then Nn(operator).Vocabulary corresponds to n1 the unique --| number of operators in Halstead's notation and --| Nn(operand).Vocabulary corresponds to n2 the unique number of --| operands. Thus --| --| Nn(operator).Vocabulary + Nn(operand).Vocabulary =n --| --| which is the vocabulary for the source program. --| --| Usage keeps track of the total usage of each class of --| operator, operand, and neither. Nn(operator).Usage --| Nn(operand).Usage correspond to N1 and N2 in Halstead --| notation and their sum corresponds to N which is the length of -------------------------------------------------------------------------- function AddCounts ( --| This function Adds two records and --| returns their sum. L :in NnInfoType; R :in NnInfoType ) return NnInfoType ; -------------------------------------------------------------------------- procedure ZeroCount (--| Sets the counts of NnInfo to 0. NnInfo :in out NnInfoType ); ------------------------------------------------------------------------- - end Count_Types; :::::::::::::: defs.bdy :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/defs.bdy,v $ -- $Revision: 5.1 $ -- $Date: 85/04/04 08:30:38 $ -- $Author: buddy $ with VmmTextPkg; with unchecked_deallocation; package body Definitions is function "<" ( --| This function compares the text of two literals --| to see if X is lexigraphically less than Y. X :in Source_Text.Locator; Y :in Source_Text.Locator ) return boolean is begin return VmmTextPkg.Value (Source_Text.Value (X)) < VmmTextPkg.Value (Source_Text.Value (Y)); end; package body Literal_Set is ------------------------------------------------------------------------------ -- Nested Private Definitions ------------------------------------------------------------------------------- package body TreePkg is --------------------------------------------------------------------------- -- Nested Private Definitions --------------------------------------------------------------------------- package body NodeOrder is procedure Free is new unchecked_deallocation (Cell, List); -------------------------------------------------------------------------- function Last (L: in List) return List is Place_In_L: List; Temp_Place_In_L: List; --| Link down the list L and return the pointer to the last element --| of L. If L is null raise the EmptyList exception. begin if L = null then raise EmptyList; else --| Link down L saving the pointer to the previous element in --| Temp_Place_In_L. After the last iteration Temp_Place_In_L --| points to the last element in the list. Place_In_L := L; while Place_In_L /= null loop Temp_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end loop; return Temp_Place_In_L; end if; end Last; -------------------------------------------------------------------------- procedure Attach (List1: in out List; List2: in List ) is EndOfList1: List; --| Attach List2 to List1. --| If List1 is null return List2 --| If List1 equals List2 then raise CircularList --| Otherwise get the pointer to the last element of List1 and change --| its Next field to be List2. begin if List1 = null then List1 := List2; return; elsif List1 = List2 then raise CircularList; else EndOfList1 := Last (List1); EndOfList1.Next := List2; end if; end Attach; -------------------------------------------------------------------------- procedure Attach (L: in out List; Element: in Tree ) is NewEnd: List; --| Create a list containing Element and attach it to the end of L begin NewEnd := new Cell'(Info => Element, Next => null); Attach (L, NewEnd); end; -------------------------------------------------------------------------- function Attach (Element1: in Tree; Element2: in Tree ) return List is NewList: List; --| Create a new list containing the information in Element1 and --| attach Element2 to that list. begin NewList := new Cell'(Info => Element1, Next => null); Attach (NewList, Element2); return NewList; end; -------------------------------------------------------------------------- procedure Attach (Element: in Tree; L: in out List ) is --| Create a new cell whose information is Element and whose Next --| field is the list L. This prepends Element to the List L. begin L := new Cell'(Info => Element, Next => L); end; -------------------------------------------------------------------------- function Attach ( List1: in List; List2: in List ) return List is Last_Of_List1: List; begin if List1 = null then return List2; elsif List1 = List2 then raise CircularList; else Last_Of_List1 := Last (List1); Last_Of_List1.Next := List2; return List1; end if; end Attach; ------------------------------------------------------------------------- function Attach( L: in List; Element: in Tree ) return List is NewEnd: List; Last_Of_L: List; --| Create a list called NewEnd and attach it to the end of L. --| If L is null return NewEnd --| Otherwise get the last element in L and make its Next field --| NewEnd. begin NewEnd := new Cell'(Info => Element, Next => null); if L = null then return NewEnd; else Last_Of_L := Last (L); Last_Of_L.Next := NewEnd; return L; end if; end Attach; -------------------------------------------------------------------------- function Attach (Element: in Tree; L: in List ) return List is begin return (new Cell'(Info => Element, Next => L)); end Attach; -------------------------------------------------------------------------- function Copy (L: in List) return List is --| If L is null return null --| Otherwise recursively copy the list by first copying the information --| at the head of the list and then making the Next field point to --| a copy of the tail of the list. begin if L = null then return null; else return new Cell'(Info => L.Info, Next => Copy (L.Next)); end if; end Copy; -------------------------------------------------------------------------- function Create return List is --| Return the empty list. begin return null; end Create; -------------------------------------------------------------------------- procedure DeleteHead (L: in out List) is TempList: List; --| Remove the element of the head of the list and return it to the heap. --| If L is null EmptyList. --| Otherwise save the Next field of the first element, remove the first --| element and then assign to L the Next field of the first element. begin if L = null then raise EmptyList; else TempList := L.Next; Free (L); L := TempList; end if; end DeleteHead; -------------------------------------------------------------------------- procedure DeleteItem (L: in out List; Element: in Tree ) is Temp_L :List; --| Remove the first element in the list with the value Element. --| If the first element of the list is equal to element then --| remove it. Otherwise, recurse on the tail of the list. begin if L.Info = Element then DeleteHead(L); else DeleteItem(L.Next, Element); end if; exception when constraint_error => raise ItemNotPresent; end DeleteItem; -------------------------------------------------------------------------- procedure DeleteItems (L: in out List; Element: in Tree ) is Place_In_L :List; --| Current place in L. Last_Place_In_L :List; --| Last place in L. Temp_Place_In_L :List; --| Holds a place in L to be removed. Found :boolean := false; --| Indicates if an element with --| the correct value was found. --| Walk over the list removing all elements with the value Element. begin Place_In_L := L; Last_Place_In_L := null; while (Place_In_L /= null) loop --| Found an element equal to Element if Place_In_L.Info = Element then Found := true; --| If Last_Place_In_L is null then we are at first element --| in L. if Last_Place_In_L = null then Temp_Place_In_L := Place_In_L; L := Place_In_L.Next; else Temp_Place_In_L := Place_In_L; --| Relink the list Last's Next gets Place's Next Last_Place_In_L.Next := Place_In_L.Next; end if; --| Move Place_In_L to the next position in the list. --| Free the element. --| Do not update the last element in the list it remains the --| same. Place_In_L := Place_In_L.Next; Free (Temp_Place_In_L); else --| Update the last place in L and the place in L. Last_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end if; end loop; --| If we have not found an element raise an exception. if not Found then raise ItemNotPresent; end if; end DeleteItems; -------------------------------------------------------------------------- procedure Destroy (L: in out List) is Place_In_L: List; HoldPlace: List; --| Walk down the list removing all the elements and set the list to --| the empty list. begin Place_In_L := L; while Place_In_L /= null loop HoldPlace := Place_In_L; Place_In_L := Place_In_L.Next; Free (HoldPlace); end loop; L := null; end Destroy; -------------------------------------------------------------------------- function FirstValue (L: in List) return Tree is --| Return the first value in the list. begin if L = null then raise EmptyList; else return (L.Info); end if; end FirstValue; -------------------------------------------------------------------------- procedure Forword (I: in out ListIter) is --| Return the pointer to the next member of the list. Temp_L :List; begin Temp_L := List (I); I := ListIter (Temp_L.Next); end Forword; -------------------------------------------------------------------------- function IsInList (L: in List; Element: in Tree ) return boolean is Place_In_L: List; --| Check if Element is in L. If it is return true otherwise return false. begin Place_In_L := L; while Place_In_L /= null loop if Place_In_L.Info = Element then return true; end if; Place_In_L := Place_In_L.Next; end loop; return false; end IsInList; -------------------------------------------------------------------------- function IsEmpty (L: in List) return boolean is --| Is the list L empty. begin return (L = null); end IsEmpty; -------------------------------------------------------------------------- function LastValue (L: in List) return Tree is LastElement: List; --| Return the value of the last element of the list. Get the pointer --| to the last element of L and then return its information. begin LastElement := Last (L); return LastElement.Info; end LastValue; -------------------------------------------------------------------------- function Length (L: in List) return integer is --| Recursively compute the length of L. The length of a list is --| 0 if it is null or 1 + the length of the tail. begin if L = null then return (0); else return (1 + Length (Tail (L))); end if; end Length; -------------------------------------------------------------------------- function MakeListIter (L: in List) return ListIter is --| Start an iteration operation on the list L. Do a type conversion --| from List to ListIter. begin return ListIter (L); end MakeListIter; -------------------------------------------------------------------------- function More (L: in ListIter) return boolean is --| This is a test to see whether an iteration is complete. begin return L /= null; end; -------------------------------------------------------------------------- procedure Next (Place: in out ListIter; Info: out Tree ) is PlaceInList: List; --| This procedure gets the information at the current place in the List --| and moves the ListIter to the next postion in the list. --| If we are at the end of a list then exception NoMore is raised. begin if Place = null then raise NoMore; else PlaceInList := List(Place); Info := PlaceInList.Info; Place := ListIter(PlaceInList.Next); end if; end Next; -------------------------------------------------------------------------- procedure ReplaceHead (L: in out List; Info: in Tree ) is --| This procedure replaces the information at the head of a list --| with the given information. If the list is empty the exception --| EmptyList is raised. begin if L = null then raise EmptyList; else L.Info := Info; end if; end ReplaceHead; -------------------------------------------------------------------------- procedure ReplaceTail (L: in out List; NewTail: in List ) is Temp_L: List; --| This destroys the tail of a list and replaces the tail with --| NewTail. If L is empty EmptyList is raised. begin Destroy(L.Next); L.Next := NewTail; exception when constraint_error => raise EmptyList; end ReplaceTail; -------------------------------------------------------------------------- function Tail (L: in List) return List is --| This returns the list which is the tail of L. If L is null Empty --| List is raised. begin if L = null then raise EmptyList; else return L.Next; end if; end Tail; -------------------------------------------------------------------------- function Equal (List1: in List; List2: in List ) return boolean is PlaceInList1: List; PlaceInList2: List; Contents1: Tree; Contents2: Tree; --| This function tests to see if two lists are equal. Two lists --| are equal if for all the elements of List1 the corresponding --| element of List2 has the same value. Thus if the 1st elements --| are equal and the second elements are equal and so up to n. --| Thus a necessary condition for two lists to be equal is that --| they have the same number of elements. --| This function walks over the two list and checks that the --| corresponding elements are equal. As soon as we reach --| the end of a list (PlaceInList = null) we fall out of the loop. --| If both PlaceInList1 and PlaceInList2 are null after exiting the loop --| then the lists are equal. If they both are not null the lists aren't --| equal. Note that equality on elements is based on a user supplied --| function Equal which is used to test for item equality. begin PlaceInList1 := List1; PlaceInList2 := List2; while (PlaceInList1 /= null) and (PlaceInList2 /= null) loop if PlaceInList1.Info /= PlaceInList2.Info then return false; end if; PlaceInList1 := PlaceInList1.Next; PlaceInList2 := PlaceInList2.Next; end loop; return ((PlaceInList1 = null) and (PlaceInList2 = null) ); end Equal; end NodeOrder; -------------------------------------------------------------------------- ---------------------------------------------------------------------------- -- Local Subprograms ---------------------------------------------------------------------------- procedure Free is new unchecked_deallocation (Node, Tree); function equal (X, Y: in Member) return boolean is begin return (not (X < Y)) and (not (Y < X)); end; ------------------------------------------------------------------------------ function Generate (T :in Tree ) return Nodeorder.List is L : Nodeorder.List; --| This routine generates a list of pointers to nodes in the tree t. --| The list is ordered with respect to the order of the nodes in the tree. --| generate does a depth first search of the tree. --| 1. It first visits the leftchild of t and generates the list for that. --| 2. It then appends the root node of t to the list generated for the left --| child. --| 3. It then appends the list generated for the rightchild to the list --| generated for the leftchild and the root. --| begin L := NodeOrder.Create; if T /= null then L := Generate (T.Leftchild); Nodeorder.Attach (L, T); Nodeorder.Attach (L, Generate (T.Rightchild)); end if; return L; End Generate; ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Visible Subprograms ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ function Create return Tree is begin return null; end; ----------------------------------------------------------------------------- procedure Deposit ( I :in Member; S :in Tree ) is begin S.Info := I; end; ------------------------------------------------------------------------------ procedure DestroyTree ( T :in out Tree) is --| This procedure recursively destroys the tree T. --| 1. It destroy the leftchild of T --| 2. It then destroys the rightchild of T. --| 3. It then destroy the root T and set T to be null. begin if T /= null then DestroyTree (T.leftchild); DestroyTree (T.rightchild); Free (T); end if; end DestroyTree; ------------------------------------------------------------------------------ procedure InsertNode ( N :in out Member; --| Node being inserted. T :in out Tree; --| Tree node is being inserted --| into. Root : out Tree; --| Root of the subtree which node N --| heads. This is the position of --| node N in T; Exists : out boolean --| If this node already exists in --| the tree then Exists is true. If --| If this is the first insertion --| Exists is false. ) is --| This inserts the node N in T. --| 1. If T is null then a new node is allocated and assigned to T --| 2. If T is not null then T is searched for the proper place to insert n. --| This is first done by checking whether N < rightchild --| 3. If this is not true then we check to see if leftchild < N --| 4. If this is not true then N is in the tree. begin if T = null then T := new Node ' (Info => N, leftchild => null, rightchild => null); Root := T; Exists := false; N := T.Info; elsif N < T.Info then InsertNode (N, T.leftchild, Root, Exists); elsif T.Info < N then InsertNode (N, T.rightchild, Root, Exists); else Root := T; Exists := true; N := T.Info; end if; end InsertNode; ------------------------------------------------------------------------------ function MakeTreeIter (T :in Tree ) return TreeIter is I :TreeIter; --| This sets up the iterator for a tree T. --| The NodeList keeps track of the order of the nodes of T. The NodeList --| is computed by first invoking Generate of the leftchild then append --| the root node to NodeList and then append the result of Generate --| to NodeList. Since the tree is ordered such that --| --| leftchild < root root < rightchild --| --| NodeOrder returns the nodes in ascending order. --| --| Thus NodeList keeps the list alive for the duration of the iteration --| operation. The variable State is the a pointer into the NodeList --| which is the current place of the iteration. begin I.NodeList := NodeOrder.Create; if T /= null then I.NodeList := Generate (T.leftchild); NodeOrder.Attach (I.NodeList, T); NodeOrder.Attach (I.NodeList, Generate (T.rightChild)); end if; I.State := NodeOrder.MakeListIter (I.NodeList); return I; end; ------------------------------------------------------------------------------ function More (I :in TreeIter) return boolean is begin return NodeOrder.More (I.State); end; ------------------------------------------------------------------------------ procedure Next ( I :in out TreeIter; Info : out Member ) is T: Tree; --| Next returns the information at the current position in the iterator --| and increments the iterator. This is accomplished by using the iterater --| associated with the NodeOrder list. This returns a pointer into the Tree --| and then the information found at this node in T is returned. begin NodeOrder.Next (I.State, T); Info := T.Info; end; ------------------------------------------------------------------------------- end TreePkg; ------------------------------------------------------------------------------- -- Local Subprograms ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- function "<" ( --| Implements "<" for the type member. X :in Member; Y :in Member ) return boolean is begin return X.Info < Y.Info; end; ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- Visible Subprograms ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- function Cardinality ( S :in Set --| The set whose size is being computed. ) return natural is T :TreePkg.TreeIter; M :Member; count :natural := 0; begin T := TreePkg.MakeTreeIter (S.SetRep); while TreePkg.More (T) loop TreePkg.Next (T, M); count := count + 1; end loop; return count; end Cardinality; ------------------------------------------------------------------------------- function Create return Set is S :Set; begin S.SetRep := TreePkg.Create; return S; end Create; ------------------------------------------------------------------------------ procedure Destroy ( S :in out Set ) is begin TreePkg.DestroyTree (S.SetRep); end Destroy; ----------------------------------------------------------------------------- function GetCount ( I :in SetIter ) return natural is begin return I.Count; end; ----------------------------------------------------------------------------- procedure Insert( M :in Source_Text.Locator; S :in out Set ) is Subtree :TreePkg.Tree; Exists :boolean; MemberToEnter :Member := ( Info => M, count => 1); begin --| If NewMember doesn't exist in SetRep it is added. If it does exist --| Exists comes back true and then M's count is updated. Since the --| first argument of TreePkg.Insert is in out, after Insert --| MemberToEnter has the value stored in the tree. Thus if we --| need to update the count we can simple bump the count in MemberToEnter. TreePkg.InsertNode (MemberToEnter, S.SetRep, SubTree, Exists); if Exists then MemberToEnter.Count := MemberToEnter.Count + 1; TreePkg.Deposit (MemberToEnter, SubTree); end if; end Insert; ------------------------------------------------------------------------------ function MakeSetIter ( S :in Set ) return SetIter is I :SetIter; begin I.Place := TreePkg.MakeTreeIter (S.SetRep); I.Count := 0; return I; end; ------------------------------------------------------------------------------ function More ( I :in SetIter ) return boolean is begin return TreePkg.More (I.Place); end; ------------------------------------------------------------------------------ procedure Next ( I :in out SetIter; M : out Source_Text.Locator ) is TempMember :Member; begin TreePkg.Next (I.Place, TempMember); M := TempMember.Info; I.Count := TempMember.Count; end; ------------------------------------------------------------------------------ end Literal_Set; package body DEF_ID_Set is ------------------------------------------------------------------------------ -- Nested Private Definitions ------------------------------------------------------------------------------- package body TreePkg is --------------------------------------------------------------------------- -- Nested Private Definitions --------------------------------------------------------------------------- package body NodeOrder is procedure Free is new unchecked_deallocation (Cell, List); -------------------------------------------------------------------------- function Last (L: in List) return List is Place_In_L: List; Temp_Place_In_L: List; --| Link down the list L and return the pointer to the last element --| of L. If L is null raise the EmptyList exception. begin if L = null then raise EmptyList; else --| Link down L saving the pointer to the previous element in --| Temp_Place_In_L. After the last iteration Temp_Place_In_L --| points to the last element in the list. Place_In_L := L; while Place_In_L /= null loop Temp_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end loop; return Temp_Place_In_L; end if; end Last; -------------------------------------------------------------------------- procedure Attach (List1: in out List; List2: in List ) is EndOfList1: List; --| Attach List2 to List1. --| If List1 is null return List2 --| If List1 equals List2 then raise CircularList --| Otherwise get the pointer to the last element of List1 and change --| its Next field to be List2. begin if List1 = null then List1 := List2; return; elsif List1 = List2 then raise CircularList; else EndOfList1 := Last (List1); EndOfList1.Next := List2; end if; end Attach; -------------------------------------------------------------------------- procedure Attach (L: in out List; Element: in Tree ) is NewEnd: List; --| Create a list containing Element and attach it to the end of L begin NewEnd := new Cell'(Info => Element, Next => null); Attach (L, NewEnd); end; -------------------------------------------------------------------------- function Attach (Element1: in Tree; Element2: in Tree ) return List is NewList: List; --| Create a new list containing the information in Element1 and --| attach Element2 to that list. begin NewList := new Cell'(Info => Element1, Next => null); Attach (NewList, Element2); return NewList; end; -------------------------------------------------------------------------- procedure Attach (Element: in Tree; L: in out List ) is --| Create a new cell whose information is Element and whose Next --| field is the list L. This prepends Element to the List L. begin L := new Cell'(Info => Element, Next => L); end; -------------------------------------------------------------------------- function Attach ( List1: in List; List2: in List ) return List is Last_Of_List1: List; begin if List1 = null then return List2; elsif List1 = List2 then raise CircularList; else Last_Of_List1 := Last (List1); Last_Of_List1.Next := List2; return List1; end if; end Attach; ------------------------------------------------------------------------- function Attach( L: in List; Element: in Tree ) return List is NewEnd: List; Last_Of_L: List; --| Create a list called NewEnd and attach it to the end of L. --| If L is null return NewEnd --| Otherwise get the last element in L and make its Next field --| NewEnd. begin NewEnd := new Cell'(Info => Element, Next => null); if L = null then return NewEnd; else Last_Of_L := Last (L); Last_Of_L.Next := NewEnd; return L; end if; end Attach; -------------------------------------------------------------------------- function Attach (Element: in Tree; L: in List ) return List is begin return (new Cell'(Info => Element, Next => L)); end Attach; -------------------------------------------------------------------------- function Copy (L: in List) return List is --| If L is null return null --| Otherwise recursively copy the list by first copying the information --| at the head of the list and then making the Next field point to --| a copy of the tail of the list. begin if L = null then return null; else return new Cell'(Info => L.Info, Next => Copy (L.Next)); end if; end Copy; -------------------------------------------------------------------------- function Create return List is --| Return the empty list. begin return null; end Create; -------------------------------------------------------------------------- procedure DeleteHead (L: in out List) is TempList: List; --| Remove the element of the head of the list and return it to the heap. --| If L is null EmptyList. --| Otherwise save the Next field of the first element, remove the first --| element and then assign to L the Next field of the first element. begin if L = null then raise EmptyList; else TempList := L.Next; Free (L); L := TempList; end if; end DeleteHead; -------------------------------------------------------------------------- procedure DeleteItem (L: in out List; Element: in Tree ) is Temp_L :List; --| Remove the first element in the list with the value Element. --| If the first element of the list is equal to element then --| remove it. Otherwise, recurse on the tail of the list. begin if L.Info = Element then DeleteHead(L); else DeleteItem(L.Next, Element); end if; exception when constraint_error => raise ItemNotPresent; end DeleteItem; -------------------------------------------------------------------------- procedure DeleteItems (L: in out List; Element: in Tree ) is Place_In_L :List; --| Current place in L. Last_Place_In_L :List; --| Last place in L. Temp_Place_In_L :List; --| Holds a place in L to be removed. Found :boolean := false; --| Indicates if an element with --| the correct value was found. --| Walk over the list removing all elements with the value Element. begin Place_In_L := L; Last_Place_In_L := null; while (Place_In_L /= null) loop --| Found an element equal to Element if Place_In_L.Info = Element then Found := true; --| If Last_Place_In_L is null then we are at first element --| in L. if Last_Place_In_L = null then Temp_Place_In_L := Place_In_L; L := Place_In_L.Next; else Temp_Place_In_L := Place_In_L; --| Relink the list Last's Next gets Place's Next Last_Place_In_L.Next := Place_In_L.Next; end if; --| Move Place_In_L to the next position in the list. --| Free the element. --| Do not update the last element in the list it remains the --| same. Place_In_L := Place_In_L.Next; Free (Temp_Place_In_L); else --| Update the last place in L and the place in L. Last_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end if; end loop; --| If we have not found an element raise an exception. if not Found then raise ItemNotPresent; end if; end DeleteItems; -------------------------------------------------------------------------- procedure Destroy (L: in out List) is Place_In_L: List; HoldPlace: List; --| Walk down the list removing all the elements and set the list to --| the empty list. begin Place_In_L := L; while Place_In_L /= null loop HoldPlace := Place_In_L; Place_In_L := Place_In_L.Next; Free (HoldPlace); end loop; L := null; end Destroy; -------------------------------------------------------------------------- function FirstValue (L: in List) return Tree is --| Return the first value in the list. begin if L = null then raise EmptyList; else return (L.Info); end if; end FirstValue; -------------------------------------------------------------------------- procedure Forword (I: in out ListIter) is --| Return the pointer to the next member of the list. Temp_L :List; begin Temp_L := List (I); I := ListIter (Temp_L.Next); end Forword; -------------------------------------------------------------------------- function IsInList (L: in List; Element: in Tree ) return boolean is Place_In_L: List; --| Check if Element is in L. If it is return true otherwise return false. begin Place_In_L := L; while Place_In_L /= null loop if Place_In_L.Info = Element then return true; end if; Place_In_L := Place_In_L.Next; end loop; return false; end IsInList; -------------------------------------------------------------------------- function IsEmpty (L: in List) return boolean is --| Is the list L empty. begin return (L = null); end IsEmpty; -------------------------------------------------------------------------- function LastValue (L: in List) return Tree is LastElement: List; --| Return the value of the last element of the list. Get the pointer --| to the last element of L and then return its information. begin LastElement := Last (L); return LastElement.Info; end LastValue; -------------------------------------------------------------------------- function Length (L: in List) return integer is --| Recursively compute the length of L. The length of a list is --| 0 if it is null or 1 + the length of the tail. begin if L = null then return (0); else return (1 + Length (Tail (L))); end if; end Length; -------------------------------------------------------------------------- function MakeListIter (L: in List) return ListIter is --| Start an iteration operation on the list L. Do a type conversion --| from List to ListIter. begin return ListIter (L); end MakeListIter; -------------------------------------------------------------------------- function More (L: in ListIter) return boolean is --| This is a test to see whether an iteration is complete. begin return L /= null; end; -------------------------------------------------------------------------- procedure Next (Place: in out ListIter; Info: out Tree ) is PlaceInList: List; --| This procedure gets the information at the current place in the List --| and moves the ListIter to the next postion in the list. --| If we are at the end of a list then exception NoMore is raised. begin if Place = null then raise NoMore; else PlaceInList := List(Place); Info := PlaceInList.Info; Place := ListIter(PlaceInList.Next); end if; end Next; -------------------------------------------------------------------------- procedure ReplaceHead (L: in out List; Info: in Tree ) is --| This procedure replaces the information at the head of a list --| with the given information. If the list is empty the exception --| EmptyList is raised. begin if L = null then raise EmptyList; else L.Info := Info; end if; end ReplaceHead; -------------------------------------------------------------------------- procedure ReplaceTail (L: in out List; NewTail: in List ) is Temp_L: List; --| This destroys the tail of a list and replaces the tail with --| NewTail. If L is empty EmptyList is raised. begin Destroy(L.Next); L.Next := NewTail; exception when constraint_error => raise EmptyList; end ReplaceTail; -------------------------------------------------------------------------- function Tail (L: in List) return List is --| This returns the list which is the tail of L. If L is null Empty --| List is raised. begin if L = null then raise EmptyList; else return L.Next; end if; end Tail; -------------------------------------------------------------------------- function Equal (List1: in List; List2: in List ) return boolean is PlaceInList1: List; PlaceInList2: List; Contents1: Tree; Contents2: Tree; --| This function tests to see if two lists are equal. Two lists --| are equal if for all the elements of List1 the corresponding --| element of List2 has the same value. Thus if the 1st elements --| are equal and the second elements are equal and so up to n. --| Thus a necessary condition for two lists to be equal is that --| they have the same number of elements. --| This function walks over the two list and checks that the --| corresponding elements are equal. As soon as we reach --| the end of a list (PlaceInList = null) we fall out of the loop. --| If both PlaceInList1 and PlaceInList2 are null after exiting the loop --| then the lists are equal. If they both are not null the lists aren't --| equal. Note that equality on elements is based on a user supplied --| function Equal which is used to test for item equality. begin PlaceInList1 := List1; PlaceInList2 := List2; while (PlaceInList1 /= null) and (PlaceInList2 /= null) loop if PlaceInList1.Info /= PlaceInList2.Info then return false; end if; PlaceInList1 := PlaceInList1.Next; PlaceInList2 := PlaceInList2.Next; end loop; return ((PlaceInList1 = null) and (PlaceInList2 = null) ); end Equal; end NodeOrder; -------------------------------------------------------------------------- ---------------------------------------------------------------------------- -- Local Subprograms ---------------------------------------------------------------------------- procedure Free is new unchecked_deallocation (Node, Tree); function equal (X, Y: in Member) return boolean is begin return (not (X < Y)) and (not (Y < X)); end; ------------------------------------------------------------------------------ function Generate (T :in Tree ) return Nodeorder.List is L : Nodeorder.List; --| This routine generates a list of pointers to nodes in the tree t. --| The list is ordered with respect to the order of the nodes in the tree. --| generate does a depth first search of the tree. --| 1. It first visits the leftchild of t and generates the list for that. --| 2. It then appends the root node of t to the list generated for the left --| child. --| 3. It then appends the list generated for the rightchild to the list --| generated for the leftchild and the root. --| begin L := NodeOrder.Create; if T /= null then L := Generate (T.Leftchild); Nodeorder.Attach (L, T); Nodeorder.Attach (L, Generate (T.Rightchild)); end if; return L; end Generate; ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Visible Subprograms ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ function Create return Tree is begin return null; end; ----------------------------------------------------------------------------- procedure Deposit ( I :in Member; S :in Tree ) is begin S.Info := I; end; ------------------------------------------------------------------------------ procedure DestroyTree ( T :in out Tree) is --| This procedure recursively destroys the tree T. --| 1. It destroy the leftchild of T --| 2. It then destroys the rightchild of T. --| 3. It then destroy the root T and set T to be null. begin if T /= null then DestroyTree (T.leftchild); DestroyTree (T.rightchild); Free (T); end if; end DestroyTree; ------------------------------------------------------------------------------ procedure InsertNode ( N :in out Member; --| Node being inserted. T :in out Tree; --| Tree node is being inserted --| into. Root : out Tree; --| Root of the subtree which node N --| heads. This is the position of --| node N in T; Exists : out boolean --| If this node already exists in --| the tree then Exists is true. If --| If this is the first insertion --| Exists is false. ) is --| This inserts the node N in T. --| 1. If T is null then a new node is allocated and assigned to T --| 2. If T is not null then T is searched for the proper place to insert n. --| This is first done by checking whether N < rightchild --| 3. If this is not true then we check to see if leftchild < N --| 4. If this is not true then N is in the tree. begin if T = null then T := new Node ' (Info => N, leftchild => null, rightchild => null); Root := T; Exists := false; N := T.Info; elsif N < T.Info then InsertNode (N, T.leftchild, Root, Exists); elsif T.Info < N then InsertNode (N, T.rightchild, Root, Exists); else Root := T; Exists := true; N := T.Info; end if; end InsertNode; ------------------------------------------------------------------------------ function MakeTreeIter (T :in Tree ) return TreeIter is I :TreeIter; --| This sets up the iterator for a tree T. --| The NodeList keeps track of the order of the nodes of T. The NodeList --| is computed by first invoking Generate of the leftchild then append --| the root node to NodeList and then append the result of Generate --| to NodeList. Since the tree is ordered such that --| --| leftchild < root root < rightchild --| --| NodeOrder returns the nodes in ascending order. --| --| Thus NodeList keeps the list alive for the duration of the iteration --| operation. The variable State is the a pointer into the NodeList --| which is the current place of the iteration. begin I.NodeList := NodeOrder.Create; if T /= null then I.NodeList := Generate (T.leftchild); NodeOrder.Attach (I.NodeList, T); NodeOrder.Attach (I.NodeList, Generate (T.rightChild)); end if; I.State := NodeOrder.MakeListIter (I.NodeList); return I; end; ------------------------------------------------------------------------------ function More (I :in TreeIter) return boolean is begin return NodeOrder.More (I.State); end; ------------------------------------------------------------------------------ procedure Next ( I :in out TreeIter; Info : out Member ) is T: Tree; --| Next returns the information at the current position in the iterator --| and increments the iterator. This is accomplished by using the iterater --| associated with the NodeOrder list. This returns a pointer into the Tree --| and then the information found at this node in T is returned. begin NodeOrder.Next (I.State, T); Info := T.Info; end; ------------------------------------------------------------------------------- end TreePkg; ------------------------------------------------------------------------------- -- Local Subprograms ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- function "<" ( --| Implements "<" for the type member. X :in Member; Y :in Member ) return boolean is begin return X.Info < Y.Info; end; ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- Visible Subprograms ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- function Cardinality ( S :in Set --| The set whose size is being computed. ) return natural is T :TreePkg.TreeIter; M :Member; count :natural := 0; begin T := TreePkg.MakeTreeIter (S.SetRep); while TreePkg.More (T) loop TreePkg.Next (T, M); count := count + 1; end loop; return count; end Cardinality; ------------------------------------------------------------------------------- function Create return Set is S :Set; begin S.SetRep := TreePkg.Create; return S; end Create; ------------------------------------------------------------------------------ procedure Destroy ( S :in out Set ) is begin TreePkg.DestroyTree (S.SetRep); end Destroy; ----------------------------------------------------------------------------- function GetCount ( I :in SetIter ) return natural is begin return I.Count; end; ----------------------------------------------------------------------------- procedure Insert( M :in DEF_ID.Locator; S :in out Set ) is Subtree :TreePkg.Tree; Exists :boolean; MemberToEnter :Member := ( Info => M, count => 1); begin --| If NewMember doesn't exist in SetRep it is added. If it does exist --| Exists comes back true and then M's count is updated. Since the --| first argument of TreePkg.Insert is in out, after Insert --| MemberToEnter has the value stored in the tree. Thus if we --| need to update the count we can simple bump the count in MemberToEnter. TreePkg.InsertNode (MemberToEnter, S.SetRep, SubTree, Exists); if Exists then MemberToEnter.Count := MemberToEnter.Count + 1; TreePkg.Deposit (MemberToEnter, SubTree); end if; end Insert; ------------------------------------------------------------------------------ function MakeSetIter ( S :in Set ) return SetIter is I :SetIter; begin I.Place := TreePkg.MakeTreeIter (S.SetRep); I.Count := 0; return I; end; ------------------------------------------------------------------------------ function More ( I :in SetIter ) return boolean is begin return TreePkg.More (I.Place); end; ------------------------------------------------------------------------------ procedure Next ( I :in out SetIter; M : out DEF_ID.Locator ) is TempMember :Member; begin TreePkg.Next (I.Place, TempMember); M := TempMember.Info; I.Count := TempMember.Count; end; ------------------------------------------------------------------------------ end DEF_ID_Set; package body BlockInfoStack is use Lists; function create return stack is begin return new stack_rec'(size => 0, elts => create); end create; procedure push(s: in out stack; e: BlockInfoType) is begin s.size := s.size + 1; s.elts := attach(e, s.elts); exception when constraint_error => raise uninitialized_stack; end push; procedure pop(s: in out stack) is begin DeleteHead(s.elts); s.size := s.size - 1; exception when EmptyList => raise empty_stack; when constraint_error => raise uninitialized_stack; end pop; procedure pop(s: in out stack; e: out BlockInfoType) is begin e := FirstValue(s.elts); DeleteHead(s.elts); s.size := s.size - 1; exception when EmptyList => raise empty_stack; when constraint_error => raise uninitialized_stack; end pop; function copy(s: stack) return stack is begin if s = null then raise uninitialized_stack; end if; return new stack_rec'(size => s.size, elts => copy(s.elts)); end; function top(s: stack) return BlockInfoType is begin return FirstValue(s.elts); exception when EmptyList => raise empty_stack; when constraint_error => raise uninitialized_stack; end top; function size(s: stack) return natural is begin return s.size; exception when constraint_error => raise uninitialized_stack; end size; function is_empty(s: stack) return boolean is begin return s.size = 0; exception when constraint_error => raise uninitialized_stack; end is_empty; procedure destroy(s: in out stack) is procedure free_stack is new unchecked_deallocation(stack_rec, stack); begin destroy(s.elts); free_stack(s); exception when constraint_error => -- stack is null return; end destroy; package body Lists is procedure Free is new unchecked_deallocation (Cell, List); function Last (L: in List) return List is Place_In_L: List; Temp_Place_In_L: List; begin if L = null then raise EmptyList; else --| Link down L saving the pointer to the previous element in --| Temp_Place_In_L. After the last iteration Temp_Place_In_L --| points to the last element in the list. Place_In_L := L; while Place_In_L /= null loop Temp_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end loop; return Temp_Place_In_L; end if; end Last; procedure Attach (List1: in out List; List2: in List ) is EndOfList1: List; --| Attach List2 to List1. --| If List1 is null return List2 --| If List1 equals List2 then raise CircularList --| Otherwise get the pointer to the last element of List1 and change --| its Next field to be List2. begin if List1 = null then List1 := List2; return; elsif List1 = List2 then raise CircularList; else EndOfList1 := Last (List1); EndOfList1.Next := List2; end if; end Attach; procedure Attach (L: in out List; Element: in BlockInfoType ) is NewEnd: List; begin NewEnd := new Cell'(Info => Element, Next => null); Attach (L, NewEnd); end; function Attach (Element1: in BlockInfoType; Element2: in BlockInfoType ) return List is NewList: List; begin NewList := new Cell'(Info => Element1, Next => null); Attach (NewList, Element2); return NewList; end; procedure Attach (Element: in BlockInfoType; L: in out List ) is begin L := new Cell'(Info => Element, Next => L); end; function Attach ( List1: in List; List2: in List ) return List is Last_Of_List1: List; begin if List1 = null then return List2; elsif List1 = List2 then raise CircularList; else Last_Of_List1 := Last (List1); Last_Of_List1.Next := List2; return List1; end if; end Attach; function Attach( L: in List; Element: in BlockInfoType ) return List is NewEnd: List; Last_Of_L: List; begin NewEnd := new Cell'(Info => Element, Next => null); if L = null then return NewEnd; else Last_Of_L := Last (L); Last_Of_L.Next := NewEnd; return L; end if; end Attach; function Attach (Element: in BlockInfoType; L: in List ) return List is begin return (new Cell'(Info => Element, Next => L)); end Attach; function Copy (L: in List) return List is begin if L = null then return null; else return new Cell'(Info => L.Info, Next => Copy (L.Next)); end if; end Copy; function Create return List is --| Return the empty list. begin return null; end Create; procedure DeleteHead (L: in out List) is TempList: List; begin if L = null then raise EmptyList; else TempList := L.Next; Free (L); L := TempList; end if; end DeleteHead; procedure DeleteItem (L: in out List; Element: in BlockInfoType ) is Temp_L :List; begin if L.Info = Element then DeleteHead(L); else DeleteItem(L.Next, Element); end if; exception when constraint_error => raise ItemNotPresent; end DeleteItem; procedure DeleteItems (L: in out List; Element: in BlockInfoType ) is Place_In_L :List; --| Current place in L. Last_Place_In_L :List; --| Last place in L. Temp_Place_In_L :List; --| Holds a place in L to be removed. Found :boolean := false; --| Indicates if an element with --| the correct value was found. begin Place_In_L := L; Last_Place_In_L := null; while (Place_In_L /= null) loop --| Found an element equal to Element if Place_In_L.Info = Element then Found := true; --| If Last_Place_In_L is null then we are at first element --| in L. if Last_Place_In_L = null then Temp_Place_In_L := Place_In_L; L := Place_In_L.Next; else Temp_Place_In_L := Place_In_L; --| Relink the list Last's Next gets Place's Next Last_Place_In_L.Next := Place_In_L.Next; end if; --| Move Place_In_L to the next position in the list. --| Free the element. --| Do not update the last element in the list it remains the --| same. Place_In_L := Place_In_L.Next; Free (Temp_Place_In_L); else --| Update the last place in L and the place in L. Last_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end if; end loop; if not Found then raise ItemNotPresent; end if; end DeleteItems; procedure Destroy (L: in out List) is Place_In_L: List; HoldPlace: List; begin Place_In_L := L; while Place_In_L /= null loop HoldPlace := Place_In_L; Place_In_L := Place_In_L.Next; Free (HoldPlace); end loop; L := null; end Destroy; function FirstValue (L: in List) return BlockInfoType is begin if L = null then raise EmptyList; else return (L.Info); end if; end FirstValue; procedure Forword (I: in out ListIter) is PlaceInList :List; begin PlaceInList := List (I); I := ListIter (PlaceInList.Next); end Forword; function IsInList (L: in List; Element: in BlockInfoType ) return boolean is Place_In_L: List; begin Place_In_L := L; while Place_In_L /= null loop if Place_In_L.Info = Element then return true; end if; Place_In_L := Place_In_L.Next; end loop; return false; end IsInList; function IsEmpty (L: in List) return boolean is --| Is the list L empty. begin return (L = null); end IsEmpty; function LastValue (L: in List) return BlockInfoType is LastElement: List; begin LastElement := Last (L); return LastElement.Info; end LastValue; function Length (L: in List) return integer is begin if L = null then return (0); else return (1 + Length (Tail (L))); end if; end Length; function MakeListIter (L: in List) return ListIter is begin return ListIter (L); end MakeListIter; function More (L: in ListIter) return boolean is begin return L /= null; end; procedure Next (Place: in out ListIter; Info: out BlockInfoType ) is PlaceInList: List; begin if Place = null then raise NoMore; else PlaceInList := List(Place); Info := PlaceInList.Info; Place := ListIter(PlaceInList.Next); end if; end Next; procedure ReplaceHead (L: in out List; Info: in BlockInfoType ) is begin if L = null then raise EmptyList; else L.Info := Info; end if; end ReplaceHead; procedure ReplaceTail (L: in out List; NewTail: in List ) is Temp_L: List; begin Destroy(L.Next); L.Next := NewTail; exception when constraint_error => raise EmptyList; end ReplaceTail; function Tail (L: in List) return List is --| This returns the list which is the tail of L. If L is null Empty --| List is raised. begin if L = null then raise EmptyList; else return L.Next; end if; end Tail; function Equal (List1: in List; List2: in List ) return boolean is PlaceInList1: List; PlaceInList2: LIst; Contents1: BlockInfoType; Contents2: BlockInfoType; --| This function tests to see if two lists are equal. Two lists --| are equal if for all the elements of List1 the corresponding --| element of List2 has the same value. Thus if the 1st elements --| are equal and the second elements are equal and so up to n. --| Thus a necessary condition for two lists to be equal is that --| they have the same number of elements. --| This function walks over the two list and checks that the --| corresponding elements are equal. As soon as we reach --| the end of a list (PlaceInList = null) we fall out of the loop. --| If both PlaceInList1 and PlaceInList2 are null after exiting the loop --| then the lists are equal. If they both are not null the lists aren't --| equal. Note that equality on elements is based on a user supplied --| function Equal which is used to test for item equality. begin PlaceInList1 := List1; PlaceInList2 := List2; while (PlaceInList1 /= null) and (PlaceInList2 /= null) loop if not "=" (PlaceInList1.Info, PlaceInList2.Info) then return false; end if; PlaceInList1 := PlaceInList1.Next; PlaceInList2 := PlaceInList2.Next; end loop; return ((PlaceInList1 = null) and (PlaceInList2 = null) ); end Equal; end Lists; end BlockInfoStack; end Definitions; :::::::::::::: defs.spc :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/defs.spc,v $ -- $Revision: 5.7 $ -- $Date: 85/09/04 09:24:19 $ -- $Author: buddy $ with ST_Diana; use ST_Diana; with ML_Source_Position_Pkg; package Definitions is --| OVERVIEW --| This package defines all the data used by the Halstead program. This --| package also defines all the operations on the data types defined. --| The following is a list of all the abstract data types which --| this package defines. --| --| --| 1. DEF_ID_Set.Set from the package DEF_ID_Set --| 2. Literal_Set.Set from the package Literal_Set --| 3. BlockInfoStack.Stack from the package BlockInfoStack --| --| The types defined here are all used to create the BlockInfoType. --| BlockInfoType keeps all the information pertaining to current block --| being processed. The type is composed of four components types which --| are: --| 1. TokenCountType --| 2. BlockIdType --| 3. Literal_Set.Set --| 4. DEF_ID_Set.Set --| --| TokenCountType keeps track of the number of times each token appears --| in the source program. --| --| BlockIdType maintains the name of the current block being --| processed, whether the block is a body or a spec, and --| the type of block whether its a procedure, package... --| --| Literal_Set This keeps a counted set of all the literals --| appearing in a given block. These literals will be --| counted as operands. --| --| DEF_ID_Set.Set This keeps a list of all the identifiers encounted --| in a block. At the end of the block all the --| identifiers are categorized into operands and --| operators. --| EFFECTS --| Associated with the three abstract data types DEF_ID_Set.Set --| Literal_Set.Set and BlockInfo.Stack are a complete set of --| operations. --| --| The operations associated with the sets DEF_ID_Set.Set and --| Literal_Set.Set are counted sets. This means that a member in the --| set has a count associated with it. Each time an insert is done --| on a member the count for the member is incremented. --| --| The operations associated with BlockInfoStack are the normal --| stack operations Push, Pop and some others. These operations are --| used to stack the information associated with a block. --| TUNING --| One way to tune this package is to cut out a lot of the functions --| which are not used. For example the users of this package do not --| use FirstValue and some of the other operations of the list package. type TokenItem is ( abortz, acceptz, accessz, allz, and_thenz, arrayz, atz, beginz, bodyz, body_packagez, body_taskz, casez, case_stmz, case_variantz, constantz, declarez, delayz, deltaz, digitsz, doz, elsez, else_ifz, else_orz, else_selectz, elsifz, endz, end_acceptz, end_beginz, end_case_stmz, end_case_variantz, end_ifz, end_loopz, end_package_bdyz, end_package_spcz, end_recordz, end_record_repz, end_selectz, end_task_spcz, entryz, exceptionz, exitz, forz, for_loopz, for_repz, functionz, genericz, gotoz, ifz, inz, in_loopz, in_membershipz, in_out_parameterz, in_parameterz, isz, is_case_stmz, is_case_variantz, is_functionz, is_genericz, is_package_bdyz, is_package_spcz, is_procedurez, is_separatez, is_subtypez, is_typez, is_task_bdyz, is_task_spcz, limitedz, loopz, modz, newz, new_allocatorz, new_derived_typez, new_generic_instz, not_in_membershipz, nullz, null_valuez, null_stmz, null_fieldz, ofz, orz, or_elsez, or_selectz, othersz, others_aggregatez, others_casez, others_exceptionz, others_variantz, outz, packagez, package_bdyz, package_spcz, pragmaz, privatez, private_sectionz, private_typez, procedurez, raisez, rangez, recordz, record_typez, record_repz, renamesz, returnz, reversez, selectz, separatez, subtypez, taskz, task_bdyz, task_spcz, terminatez, thenz, then_andz, typez, usez, use_contextz, use_repz, whenz, when_case_stmz, when_exitz, when_exceptionz, when_selectz, when_case_variantz, whilez, withz, with_contextz, with_genericz, ------------- punctuation -------------- arrowz, barz, boxz, box_rangez, box_default_subpz, character_literalz, closed_anglesz, closed_parenthesisz, colon_equalsz, colonz, commaz, dotz, dot_dot_rangez, double_quotez, numeric_literalz, open_anglesz, open_parenthesisz, semicolonz, single_quotez, tickz, declare_blockz ); --| These are all the tokens which could possibly be counted by --| Halstead. type Class is (operator, operand, neither); --| These are the different ways to classify symbols in the source --| program. type TokenCountType is array(TokenItem) of natural; --| This type is used to count the occurrences of each token --| in the source program. type TokenClassificationType is array(TokenItem) of Class; --| This type is used to defined whether tokens are operators --| or operands or neither. type BlockKind is ( procedure_block, function_block, package_body_block, package_spec_block, task_body_block, task_spec_block, declare_block ); --| This keeps track of the type of block being processed currently. BlockNameLength: constant := 16; --| Maximum length of a block name. SpcBdyIdLength: constant := 13; --| Maximum lenght of a string which indicates whether a block --| is a spec, body, or declare block. subtype SpcBdyIdType is string(1..SpcBdyIdLength); AnonId :constant SpcBdyIdType := " "; BdyId :constant SpcBdyIdType := "BODY "; DecId :constant SpcBdyIdType := "DECLARE BLOCK"; SpcId :constant SpcBdyIdType := "SPECIFICATION"; --| These are used to initialize the SpcOrBdyId field of --| BlockIdType. type StringPtr is access String; --| This is used to keep track of the fully qualified name of the --| block being processed. Each time a new scope is entered --| the name of that scope is concatenated with the current --| fully qualified name. type BlockIdType is record KindOfBlock :BlockKind; SpcBdyId :SpcBdyIdType; BlockName :StringPtr; LineLocation :ML_Source_Position_Pkg.Source_Line; end record; --| This type keeps track of the name of a block. For instance --| if we are processing the body of procedure P then the name --| of the block is P. The KindOfBlock is "PROCEDURE" and --| SpcOrBdyId = "(B)". --| The following code represents a generic instantiation of the --| OrderedSet package. It replaces: --| --| package DEF_ID_Set is new OrderedSet --| (ItemType => DEF_ID.Locator, --| "<" => ST_Diana.DEF_ID."<"); -------------------------------------------------------------------------- -- GENERIC INSTANTIATION -------------------------------------------------------------------------- function "<" ( X, Y: DEF_ID.Locator) return boolean renames ST_Diana.DEF_ID."<"; package DEF_ID_Set is --| Overview --| This abstractions is a counted ordered set. This means that --| associated with each member of the set is a count of the number of --| times it appears in the set. The order part means that there is --| an ordering associated with the members. This allows fast insertion. --| It also makes it easy to iterate over the set in order. -- Types -- ----- type Set is private; --| This is the type exported to represent --| the ordered set. type SetIter is private; --| This is the type exported whose --| purpose is to walk over a set. -- Operations -- ---------- --| Cardinality Returns cardinality of the set. --| Create Creates the empty set. --| CountMember Returns the number of times the member appears in --| the set. --| Destroy Destroys a set and returns the space it occupies. --| Insert Insert a member into the set. --| MakeSetIter Return a SetIter which will begin an iteration. --| More Are there more elements to iterate over in the --| set. --| Next Return the next element in the iteration and --| bump the iterator. ------------------------------------------------------------------------------ function Cardinality ( --| Return the number of members in the set. S :in Set --| The set whose members are being counted. ) return natural; ------------------------------------------------------------------------------ function Create --| Return the empty set. return Set; ------------------------------------------------------------------------------ procedure Destroy ( --| Destroy a set and return its space. S :in out Set --| Set being destroyed. ); ------------------------------------------------------------------------------ function GetCount ( --| This returns the count associated with --| member which corresponds to the current --| iterator I. I :in SetIter ) return natural; ----------------------------------------------------------------------------- procedure Insert ( --| Insert a member M into set S. M :in DEF_ID.Locator; --| Member being inserted. S :in out Set --| Set being inserted into. ); ------------------------------------------------------------------------------ function MakeSetIter ( --| Prepares a user for an iteration operation by --| by returning a SetIter. S :in Set --| Set being iterate over. ) return SetIter; ------------------------------------------------------------------------------ function More ( --| Returns true if there are more elements in the --| set to iterate over. I :in SetIter --| The iterator. ) return boolean; ------------------------------------------------------------------------------ procedure Next ( --| Returns the current member in the iteration --| an increments the iterator. I :in out SetIter; --| The iterator. M : out DEF_ID.Locator --| The current member being returned. ); ----------------------------------------------------------------------------- private type Member is record Info :DEF_ID.Locator; Count :natural; end record; function "<" ( X:in Member; Y:in Member ) return boolean; -- generic instantiation --package TreePkg is new BinaryTrees ( DEF_ID.Locator => Member, "<" => "<" ); package TreePkg is --| Overview --| This package creates an ordered binary tree. This will allow for --| quick insertion, and search. --| --| The tree is organized such that --| --| leftchild < root root < rightchild --| --| This means that by doing a left to right search of the tree will can --| produce the nodes of the tree in ascending order. -- Types -- ----- type Tree is private; --| This is the type exported to represent the --| tree. type TreeIter is private; --| This is the type which is used to iterate --| over the set. --| Exceptions --| ---------- --| Operations --| ---------- --| --| Create Creates a tree. --| Deposit Replaces the given node's information with --| the given information. --| DestroyTree Destroys the given tree and returns the spaces. --| InsertNode This inserts a node n into a tree t. --| MakeTreeIter This returns an iterator to the user in order to start --| an iteration. --| More This returns true if there are more elements to iterate --| over in the tree. --| Next This returns the information associated with the current --| iterator and advances the iterator. --------------------------------------------------------------------------- function Create --| This function creates the tree. return Tree; --| Effects --| This creates a tree containing no information and no children. An --| emptytree. ------------------------------------------------------------------------------- procedure Deposit ( --| This deposits the information I in the --| root of the Tree S. I :in Member; --| The information being deposited. S :in Tree --| The tree where the information is being --| stored. ); --| Modifies --| This changes the information stored at the root of the tree S. ------------------------------------------------------------------------------- procedure DestroyTree ( --| Destroys a tree. T :in out Tree --| Tree being destroyed. ); --| Effects --| Destroys a tree and returns the space which it is occupying. -------------------------------------------------------------------------- Procedure Insertnode( --| This Procedure Inserts A Node Into The --| Specified Tree. N :In Out Member; --| The Information To Be Contained In The --| Node Being Inserted. T :In Out Tree; --| Tree Being Inserted Into. Root : Out Tree; --| Root of the subtree which Node N heads. --| This is the position of the node N in T. Exists : out boolean --| If this node already exists in the tree --| Exists is true. If this is the first --| insertion Exists is false. ); --| Effects --| This adds the node N to the tree T inserting in the proper postion. --| Modifies --| This modifies the tree T by add the node N to it. ------------------------------------------------------------------------------ function MakeTreeIter ( --| Sets a variable to a position in the --| tree --| where the iteration is to begin. In this --| case the position is a pointer to the --| the deepest leftmost leaf in the tree. T:in Tree --| Tree being iterated over ) return TreeIter; --| Effects ----------------------------------------------------------------------------- function More ( --| Returns true if there are more elements --| in the tree to iterate over. I :in TreeIter ) return boolean; ----------------------------------------------------------------------------- procedure Next ( --| This is the iterator operation. Given --| an Iter in the Tree it returns the --| item Iter points to and updates the --| iter. If Iter is at the end of the Tree, --| yielditer returns false otherwise it --| returns true. I :in out TreeIter; --| The iter which marks the position in the --| Tree. Info : out Member --| Information being returned from a node. ); --------------------------------------------------------------------------- private type Node; type Tree is access Node; type Node is record Info :Member; LeftChild :Tree; RightChild :Tree; end record; --- The following is a generic instantiation of NodeOrder --- package NodeOrder is new Lists (Tree); package NodeOrder is --| This package provides singly linked lists with elements of type --| Tree, where Tree is specified by a generic parameter. --| Overview --| When this package is instantiated, it provides a linked list type for --| lists of objects of type Tree, which can be any desired type. A --| complete set of operations for manipulation, and releasing --| those lists is also provided. For instance, to make lists of strings, --| all that is necessary is: --| --| type StringType is string(1..10); --| --| package Str_List is new Lists(StringType); use Str_List; --| --| L:List; --| S:StringType; --| --| Then to add a string S, to the list L, all that is necessary is --| --| L := Create; --| Attach(S,L); --| --| --| This package provides basic list operations. --| --| Attach append an object to an object, an object to a list, --| or a list to an object, or a list to a list. --| Copy copy a list using := on elements --| CopyDeep copy a list by copying the elements using a copy --| operation provided by the user --| Create Creates an empty list --| DeleteHead removes the head of a list --| DeleteItem delete the first occurrence of an element from a list --| DeleteItems delete all occurrences of an element from a list --| Destroy remove a list --| Equal are two lists equal --| FirstValue get the information from the first element of a list --| IsInList determines whether a given element is in a given list --| IsEmpty returns true if the list is empty --| LastValue return the last value of a list --| Length Returns the length of a list --| MakeListIter prepares for an iteration over a list --| More are there any more items in the list --| Next get the next item in a list --| ReplaceHead replace the information at the head of the list --| ReplaceTail replace the tail of a list with a new list --| Tail get the tail of a list --| --| N/A: Effects, Requires, Modifies, and Raises. --| Notes --| Programmer Buddy Altus --| Types --| ----- type List is private; type ListIter is private; --| Exceptions --| ---------- CircularList :exception; --| Raised if an attemp is made to --| create a circular list. This --| results when a list is attempted --| to be attached to itself. EmptyList :exception; --| Raised if an attemp is made to --| manipulate an empty list. ItemNotPresent :exception; --| Raised if an attempt is made to --| remove an element from a list in --| which it does not exist. NoMore :exception; --| Raised if an attemp is made to --| get the next element from a list --| after iteration is complete. --| Operations --| ---------- ---------------------------------------------------------------------------- procedure Attach( --| appends List2 to List1 List1: in out List; --| The list being appended to. List2: in List --| The list being appended. ); --| Raises --| CircularList --| Effects --| Appends List1 to List2. This makes the next field of the last element --| of List1 refer to List2. This can possibly change the value of List1 --| if List1 is an empty list. This causes sharing of lists. Thus if --| user Destroys List1 then List2 will be a dangling reference. --| This procedure raises CircularList if List1 equals List2. If it is --| necessary to Attach a list to itself first make a copy of the list and --| attach the copy. --| Modifies --| Changes the next field of the last element in List1 to be List2. ------------------------------------------------------------------------------- function Attach( --| Creates a new list containing the two --| Elements. Element1: in Tree; --| This will be first element in list. Element2: in Tree --| This will be second element in list. ) return List; --| Effects --| This creates a list containing the two elements in the order --| specified. ------------------------------------------------------------------------------- procedure Attach( --| List L is appended with Element. L: in out List; --| List being appended to. Element: in Tree --| This will be last element in l ist. ); --| Effects --| Appends Element onto the end of the list L. If L is empty then this --| may change the value of L. --| --| Modifies --| This appends List L with Element by changing the next field in List. -------------------------------------------------------------------------------- procedure Attach( --| Makes Element first item in list L. Element: in Tree; --| This will be the first element in list. L: in out List --| The List which Element is being --| prepended to. ); --| Effects --| This prepends list L with Element. --| --| Modifies --| This modifies the list L. -------------------------------------------------------------------------- function Attach ( --| attaches two lists List1: in List; --| first list List2: in List --| second list ) return List; --| Raises --| CircularList --| Effects --| This returns a list which is List1 attached to List2. If it is desired --| to make List1 be the new attached list the following ada code should be --| used. --| --| List1 := Attach (List1, List2); --| This procedure raises CircularList if List1 equals List2. If it is --| necessary to Attach a list to itself first make a copy of the list and --| attach the copy. ------------------------------------------------------------------------- function Attach ( --| prepends an element onto a list Element: in Tree; --| element being prepended to list L: in List --| List which element is being added --| to ) return List; --| Effects --| Returns a new list which is headed by Element and followed by L. ------------------------------------------------------------------------ function Attach ( --| Adds an element to the end of a list L: in List; --| The list which element is being added to. Element: in Tree --| The element being added to the end of --| the list. ) return List; --| Effects --| Returns a new list which is L followed by Element. -------------------------------------------------------------------------- function Copy( --| returns a copy of list1 L: in List --| list being copied ) return List; --| Effects --| Returns a copy of L. -------------------------------------------------------------------------- function Create --| Returns an empty List return List; ------------------------------------------------------------------------------ procedure DeleteHead( --| Remove the head element from a list. L: in out List --| The list whose head is being removed. ); --| Raises --| EmptyList --| --| Effects --| This will return the space occupied by the first element in the list --| to the heap. If sharing exists between lists this procedure --| could leave a dangling reference. If L is empty EmptyList will be --| raised. ------------------------------------------------------------------------------ procedure DeleteItem( --| remove the first occurrence of Element --| from L L: in out List; --| list element is being removed from Element: in Tree --| element being removed ); --| Raises --| ItemNotPresent --| Effects --| Removes the first element of the list equal to Element. If there is --| not an element equal to Element than ItemNotPresent is raised. --| Modifies --| This operation is destructive, it returns the storage occupied by --| the elements being deleted. ------------------------------------------------------------------------------ procedure DeleteItems( --| remove all occurrences of Element --| from L. L: in out List; --| The List element is being removed from Element: in Tree --| element being removed ); --| Raises --| ItemNotPresent --| --| Effects --| This procedure walks down the list L and removes all elements of the --| list equal to Element. If there are not any elements equal to Element --| then raise ItemNotPresent. --| Modifies --| This operation is destructive the storage occupied by the items --| removed is returned. ------------------------------------------------------------------------------ procedure Destroy( --| removes the list L: in out List --| the list being removed ); --| Effects --| This returns to the heap all the storage that a list occupies. Keep in --| mind if there exists sharing between lists then this operation can leave --| dangling references. ------------------------------------------------------------------------------ function FirstValue( --| returns the contents of the first record of the --| list L: in List --| the list whose first element is being --| returned ) return Tree; --| Raises --| EmptyList --| --| Effects --| This returns the Item in the first position in the list. If the list --| is empty EmptyList is raised. ------------------------------------------------------------------------------- function IsEmpty( --| Checks if a list is empty. L: in List --| List being checked. ) return boolean; -------------------------------------------------------------------------- function IsInList( --| Checks if element is an element of --| list. L: in List; --| list being scanned for element Element: in Tree --| element being searched for ) return boolean; --| Effects --| Walks down the list L looking for an element whose value is Element. ------------------------------------------------------------------------------ function LastValue( --| Returns the contents of the last record of --| the list. L: in List --| The list whose first element is being --| returned. ) return Tree; --| Raises --| EmptyList --| --| Effects --| Returns the last element in a list. If the list is empty EmptyList is --| raised. ------------------------------------------------------------------------------ function Length( --| count the number of elements on a list L: in List --| list whose length is being computed ) return integer; ------------------------------------------------------------------------------ function MakeListIter( --| Sets a variable to point to the head --| of the list. This will be used to --| prepare for iteration over a list. L: in List --| The list being iterated over. ) return ListIter; --| This prepares a user for iteration operation over a list. The iterater is --| an operation which returns successive elements of the list on successive --| calls to the iterator. There needs to be a mechanism which marks the --| position in the list, so on successive calls to the Next operation the --| next item in the list can be returned. This is the function of the --| MakeListIter and the type ListIter. MakeIter just sets the Iter to the --| the beginning of the list. On subsequent calls to NextList the Iter --| is updated with each call. ----------------------------------------------------------------------------- function More( --| Returns true if there are more elements in --| the and false if there aren't any more --| the in the list. L: in ListIter --| List being checked for elements. ) return boolean; ------------------------------------------------------------------------------ procedure Next( --| This is the iterator operation. Given --| a ListIter in the list it returns the --| current item and updates the ListIter. --| If ListIter is at the end of the list, --| More returns false otherwise it --| returns true. Place: in out ListIter; --| The Iter which marks the position in --| the list. Info: out Tree --| The element being returned. ); --| The iterators subprograms MakeListIter, More, and NextList should be used --| in the following way: --| --| L: List; --| Place: ListIter; --| Info: SomeType; --| --| --| Place := MakeListIter(L); --| --| while ( More(Place) ) loop --| NextList(Place, Info); --| process each element of list L; --| end loop; ---------------------------------------------------------------------------- procedure ReplaceHead( --| Replace the Item at the head of the list --| with the parameter Item. L: in out List; --| The list being modified. Info: in Tree --| The information being entered. ); --| Raises --| EmptyList --| Effects --| Replaces the information in the first element in the list. Raises --| EmptyList if the list is empty. ------------------------------------------------------------------------------ procedure ReplaceTail( --| Replace the Tail of a list --| with a new list. L: in out List; --| List whose Tail is replaced. NewTail: in List --| The list which will become the --| tail of Oldlist. ); --| Raises --| EmptyList --| --| Effects --| Replaces the tail of a list with a new list. If the list whose tail --| is being replaced is null EmptyList is raised. ------------------------------------------------------------------------------- function Tail( --| returns the tail of a list L L: in List --| the list whose tail is being returned ) return List; --| Raises --| EmptyList --| --| Effects --| Returns a list which is the tail of the list L. Raises EmptyList if --| L is empty. If L only has one element then Tail returns the Empty --| list. ------------------------------------------------------------------------------ function Equal( --| compares list1 and list2 for equality List1: in List; --| first list List2: in List --| second list ) return boolean; --| Effects --| Returns true if for all elements of List1 the corresponding element --| of List2 has the same value. This function uses the Equal operation --| provided by the user. If one is not provided then = is used. ------------------------------------------------------------------------------ private type Cell; type List is access Cell; --| pointer added by this package --| in order to make a list type Cell is --| Cell for the lists being created record Info: Tree; Next: List; end record; type ListIter is new List; --| This prevents Lists being assigned to --| iterators and vice versa end NodeOrder; type TreeIter is record NodeList :NodeOrder.List; State :NodeOrder.ListIter; end record; end TreePkg; type Set is record SetRep :TreePkg.Tree; end record; type SetIter is record Place :TreePkg.TreeIter; Count :natural; end record; end DEF_ID_Set; function "<" ( --| This is used to order the Source_Text.Locs X :in Source_Text.Locator; Y :in Source_Text.Locator ) return boolean; -- generic -- type Source_Text.Locator is private; -- with function "<" ( X ,Y: in Source_Text.Locator) return boolean; package Literal_Set is --| Overview --| This abstractions is a counted ordered set. This means that --| associated with each member of the set is a count of the number of --| times it appears in the set. The order part means that there is --| an ordering associated with the members. This allows fast insertion. --| It also makes it easy to iterate over the set in order. -- Types -- ----- type Set is private; --| This is the type exported to represent --| the ordered set. type SetIter is private; --| This is the type exported whose --| purpose is to walk over a set. -- Operations -- ---------- --| Cardinality Returns cardinality of the set. --| Create Creates the empty set. --| CountMember Returns the number of times the member appears in --| the set. --| Destroy Destroys a set and returns the space it occupies. --| Insert Insert a member into the set. --| MakeSetIter Return a SetIter which will begin an iteration. --| More Are there more elements to iterate over in the --| set. --| Next Return the next element in the iteration and --| bump the iterator. ------------------------------------------------------------------------------ function Cardinality ( --| Return the number of members in the set. S :in Set --| The set whose members are being counted. ) return natural; ------------------------------------------------------------------------------ function Create --| Return the empty set. return Set; ------------------------------------------------------------------------------ procedure Destroy ( --| Destroy a set and return its space. S :in out Set --| Set being destroyed. ); ------------------------------------------------------------------------------ function GetCount ( --| This returns the count associated with --| member which corresponds to the current --| iterator I. I :in SetIter ) return natural; ----------------------------------------------------------------------------- procedure Insert ( --| Insert a member M into set S. M :in Source_Text.Locator; --| Member being inserted. S :in out Set --| Set being inserted into. ); ------------------------------------------------------------------------------ function MakeSetIter ( --| Prepares a user for an iteration operation by --| by returning a SetIter. S :in Set --| Set being iterate over. ) return SetIter; ------------------------------------------------------------------------------ function More ( --| Returns true if there are more elements in the --| set to iterate over. I :in SetIter --| The iterator. ) return boolean; ------------------------------------------------------------------------------ procedure Next ( --| Returns the current member in the iteration --| an increments the iterator. I :in out SetIter; --| The iterator. M : out Source_Text.Locator --| The current member being returned. ); ----------------------------------------------------------------------------- private type Member is record Info :Source_Text.Locator; Count :natural; end record; function "<" ( X:in Member; Y:in Member ) return boolean; -- generic instantiation --package TreePkg is new BinaryTrees ( Source_Text.Locator => Member, "<" => "<" ); package TreePkg is --| Overview --| This package creates an ordered binary tree. This will allow for --| quick insertion, and search. --| --| The tree is organized such that --| --| leftchild < root root < rightchild --| --| This means that by doing a left to right search of the tree will can --| produce the nodes of the tree in ascending order. -- Types -- ----- type Tree is private; --| This is the type exported to represent the --| tree. type TreeIter is private; --| This is the type which is used to iterate --| over the set. --| Exceptions --| ---------- --| Operations --| ---------- --| --| Create Creates a tree. --| Deposit Replaces the given node's information with --| the given information. --| DestroyTree Destroys the given tree and returns the spaces. --| InsertNode This inserts a node n into a tree t. --| MakeTreeIter This returns an iterator to the user in order to start --| an iteration. --| More This returns true if there are more elements to iterate --| over in the tree. --| Next This returns the information associated with the current --| iterator and advances the iterator. --------------------------------------------------------------------------- function Create --| This function creates the tree. return Tree; --| Effects --| This creates a tree containing no information and no children. An --| emptytree. ------------------------------------------------------------------------------- procedure Deposit ( --| This deposits the information I in the --| root of the Tree S. I :in Member; --| The information being deposited. S :in Tree --| The tree where the information is being --| stored. ); --| Modifies --| This changes the information stored at the root of the tree S. ------------------------------------------------------------------------------- procedure DestroyTree ( --| Destroys a tree. T :in out Tree --| Tree being destroyed. ); --| Effects --| Destroys a tree and returns the space which it is occupying. -------------------------------------------------------------------------- Procedure Insertnode( --| This Procedure Inserts A Node Into The --| Specified Tree. N :In Out Member; --| The Information To Be Contained In The --| Node Being Inserted. T :In Out Tree; --| Tree Being Inserted Into. Root : Out Tree; --| Root of the subtree which Node N heads. --| This is the position of the node N in T. Exists : out boolean --| If this node already exists in the tree --| Exists is true. If this is the first --| insertion Exists is false. ); --| Effects --| This adds the node N to the tree T inserting in the proper postion. --| Modifies --| This modifies the tree T by add the node N to it. ------------------------------------------------------------------------------ function MakeTreeIter ( --| Sets a variable to a position in the --| tree --| where the iteration is to begin. In this --| case the position is a pointer to the --| the deepest leftmost leaf in the tree. T:in Tree --| Tree being iterated over ) return TreeIter; --| Effects ----------------------------------------------------------------------------- function More ( --| Returns true if there are more elements --| in the tree to iterate over. I :in TreeIter ) return boolean; ----------------------------------------------------------------------------- procedure Next ( --| This is the iterator operation. Given --| an Iter in the Tree it returns the --| item Iter points to and updates the --| iter. If Iter is at the end of the Tree, --| yielditer returns false otherwise it --| returns true. I :in out TreeIter; --| The iter which marks the position in the --| Tree. Info : out Member --| Information being returned from a node. ); --------------------------------------------------------------------------- private type Node; type Tree is access Node; type Node is record Info :Member; LeftChild :Tree; RightChild :Tree; end record; --- The following is a generic instantiation of NodeOrder --- package NodeOrder is new Lists (Tree); package NodeOrder is --| This package provides singly linked lists with elements of type --| Tree, where Tree is specified by a generic parameter. --| Overview --| When this package is instantiated, it provides a linked list type for --| lists of objects of type Tree, which can be any desired type. A --| complete set of operations for manipulation, and releasing --| those lists is also provided. For instance, to make lists of strings, --| all that is necessary is: --| --| type StringType is string(1..10); --| --| package Str_List is new Lists(StringType); use Str_List; --| --| L:List; --| S:StringType; --| --| Then to add a string S, to the list L, all that is necessary is --| --| L := Create; --| Attach(S,L); --| --| --| This package provides basic list operations. --| --| Attach append an object to an object, an object to a list, --| or a list to an object, or a list to a list. --| Copy copy a list using := on elements --| CopyDeep copy a list by copying the elements using a copy --| operation provided by the user --| Create Creates an empty list --| DeleteHead removes the head of a list --| DeleteItem delete the first occurrence of an element from a list --| DeleteItems delete all occurrences of an element from a list --| Destroy remove a list --| Equal are two lists equal --| FirstValue get the information from the first element of a list --| IsInList determines whether a given element is in a given list --| IsEmpty returns true if the list is empty --| LastValue return the last value of a list --| Length Returns the length of a list --| MakeListIter prepares for an iteration over a list --| More are there any more items in the list --| Next get the next item in a list --| ReplaceHead replace the information at the head of the list --| ReplaceTail replace the tail of a list with a new list --| Tail get the tail of a list --| --| N/A: Effects, Requires, Modifies, and Raises. --| Notes --| Programmer Buddy Altus --| Types --| ----- type List is private; type ListIter is private; --| Exceptions --| ---------- CircularList :exception; --| Raised if an attemp is made to --| create a circular list. This --| results when a list is attempted --| to be attached to itself. EmptyList :exception; --| Raised if an attemp is made to --| manipulate an empty list. ItemNotPresent :exception; --| Raised if an attempt is made to --| remove an element from a list in --| which it does not exist. NoMore :exception; --| Raised if an attemp is made to --| get the next element from a list --| after iteration is complete. --| Operations --| ---------- ---------------------------------------------------------------------------- procedure Attach( --| appends List2 to List1 List1: in out List; --| The list being appended to. List2: in List --| The list being appended. ); --| Raises --| CircularList --| Effects --| Appends List1 to List2. This makes the next field of the last element --| of List1 refer to List2. This can possibly change the value of List1 --| if List1 is an empty list. This causes sharing of lists. Thus if --| user Destroys List1 then List2 will be a dangling reference. --| This procedure raises CircularList if List1 equals List2. If it is --| necessary to Attach a list to itself first make a copy of the list and --| attach the copy. --| Modifies --| Changes the next field of the last element in List1 to be List2. ------------------------------------------------------------------------------- function Attach( --| Creates a new list containing the two --| Elements. Element1: in Tree; --| This will be first element in list. Element2: in Tree --| This will be second element in list. ) return List; --| Effects --| This creates a list containing the two elements in the order --| specified. ------------------------------------------------------------------------------- procedure Attach( --| List L is appended with Element. L: in out List; --| List being appended to. Element: in Tree --| This will be last element in l ist. ); --| Effects --| Appends Element onto the end of the list L. If L is empty then this --| may change the value of L. --| --| Modifies --| This appends List L with Element by changing the next field in List. -------------------------------------------------------------------------------- procedure Attach( --| Makes Element first item in list L. Element: in Tree; --| This will be the first element in list. L: in out List --| The List which Element is being --| prepended to. ); --| Effects --| This prepends list L with Element. --| --| Modifies --| This modifies the list L. -------------------------------------------------------------------------- function Attach ( --| attaches two lists List1: in List; --| first list List2: in List --| second list ) return List; --| Raises --| CircularList --| Effects --| This returns a list which is List1 attached to List2. If it is desired --| to make List1 be the new attached list the following ada code should be --| used. --| --| List1 := Attach (List1, List2); --| This procedure raises CircularList if List1 equals List2. If it is --| necessary to Attach a list to itself first make a copy of the list and --| attach the copy. ------------------------------------------------------------------------- function Attach ( --| prepends an element onto a list Element: in Tree; --| element being prepended to list L: in List --| List which element is being added --| to ) return List; --| Effects --| Returns a new list which is headed by Element and followed by L. ------------------------------------------------------------------------ function Attach ( --| Adds an element to the end of a list L: in List; --| The list which element is being added to. Element: in Tree --| The element being added to the end of --| the list. ) return List; --| Effects --| Returns a new list which is L followed by Element. -------------------------------------------------------------------------- function Copy( --| returns a copy of list1 L: in List --| list being copied ) return List; --| Effects --| Returns a copy of L. -------------------------------------------------------------------------- function Create --| Returns an empty List return List; ------------------------------------------------------------------------------ procedure DeleteHead( --| Remove the head element from a list. L: in out List --| The list whose head is being removed. ); --| Raises --| EmptyList --| --| Effects --| This will return the space occupied by the first element in the list --| to the heap. If sharing exists between lists this procedure --| could leave a dangling reference. If L is empty EmptyList will be --| raised. ------------------------------------------------------------------------------ procedure DeleteItem( --| remove the first occurrence of Element --| from L L: in out List; --| list element is being removed from Element: in Tree --| element being removed ); --| Raises --| ItemNotPresent --| Effects --| Removes the first element of the list equal to Element. If there is --| not an element equal to Element than ItemNotPresent is raised. --| Modifies --| This operation is destructive, it returns the storage occupied by --| the elements being deleted. ------------------------------------------------------------------------------ procedure DeleteItems( --| remove all occurrences of Element --| from L. L: in out List; --| The List element is being removed from Element: in Tree --| element being removed ); --| Raises --| ItemNotPresent --| --| Effects --| This procedure walks down the list L and removes all elements of the --| list equal to Element. If there are not any elements equal to Element --| then raise ItemNotPresent. --| Modifies --| This operation is destructive the storage occupied by the items --| removed is returned. ------------------------------------------------------------------------------ procedure Destroy( --| removes the list L: in out List --| the list being removed ); --| Effects --| This returns to the heap all the storage that a list occupies. Keep in --| mind if there exists sharing between lists then this operation can leave --| dangling references. ------------------------------------------------------------------------------ function FirstValue( --| returns the contents of the first record of the --| list L: in List --| the list whose first element is being --| returned ) return Tree; --| Raises --| EmptyList --| --| Effects --| This returns the Item in the first position in the list. If the list --| is empty EmptyList is raised. ------------------------------------------------------------------------------- function IsEmpty( --| Checks if a list is empty. L: in List --| List being checked. ) return boolean; -------------------------------------------------------------------------- function IsInList( --| Checks if element is an element of --| list. L: in List; --| list being scanned for element Element: in Tree --| element being searched for ) return boolean; --| Effects --| Walks down the list L looking for an element whose value is Element. ------------------------------------------------------------------------------ function LastValue( --| Returns the contents of the last record of --| the list. L: in List --| The list whose first element is being --| returned. ) return Tree; --| Raises --| EmptyList --| --| Effects --| Returns the last element in a list. If the list is empty EmptyList is --| raised. ------------------------------------------------------------------------------ function Length( --| count the number of elements on a list L: in List --| list whose length is being computed ) return integer; ------------------------------------------------------------------------------ function MakeListIter( --| Sets a variable to point to the head --| of the list. This will be used to --| prepare for iteration over a list. L: in List --| The list being iterated over. ) return ListIter; --| This prepares a user for iteration operation over a list. The iterater is --| an operation which returns successive elements of the list on successive --| calls to the iterator. There needs to be a mechanism which marks the --| position in the list, so on successive calls to the Next operation the --| next item in the list can be returned. This is the function of the --| MakeListIter and the type ListIter. MakeIter just sets the Iter to the --| the beginning of the list. On subsequent calls to NextList the Iter --| is updated with each call. ----------------------------------------------------------------------------- function More( --| Returns true if there are more elements in --| the and false if there aren't any more --| the in the list. L: in ListIter --| List being checked for elements. ) return boolean; ------------------------------------------------------------------------------ procedure Next( --| This is the iterator operation. Given --| a ListIter in the list it returns the --| current item and updates the ListIter. --| If ListIter is at the end of the list, --| More returns false otherwise it --| returns true. Place: in out ListIter; --| The Iter which marks the position in --| the list. Info: out Tree --| The element being returned. ); --| The iterators subprograms MakeListIter, More, and NextList should be used --| in the following way: --| --| L: List; --| Place: ListIter; --| Info: SomeType; --| --| --| Place := MakeListIter(L); --| --| while ( More(Place) ) loop --| NextList(Place, Info); --| process each element of list L; --| end loop; ---------------------------------------------------------------------------- procedure ReplaceHead( --| Replace the Item at the head of the list --| with the parameter Item. L: in out List; --| The list being modified. Info: in Tree --| The information being entered. ); --| Raises --| EmptyList --| Effects --| Replaces the information in the first element in the list. Raises --| EmptyList if the list is empty. ------------------------------------------------------------------------------ procedure ReplaceTail( --| Replace the Tail of a list --| with a new list. L: in out List; --| List whose Tail is replaced. NewTail: in List --| The list which will become the --| tail of Oldlist. ); --| Raises --| EmptyList --| --| Effects --| Replaces the tail of a list with a new list. If the list whose tail --| is being replaced is null EmptyList is raised. ------------------------------------------------------------------------------- function Tail( --| returns the tail of a list L L: in List --| the list whose tail is being returned ) return List; --| Raises --| EmptyList --| --| Effects --| Returns a list which is the tail of the list L. Raises EmptyList if --| L is empty. If L only has one element then Tail returns the Empty --| list. ------------------------------------------------------------------------------ function Equal( --| compares list1 and list2 for equality List1: in List; --| first list List2: in List --| second list ) return boolean; --| Effects --| Returns true if for all elements of List1 the corresponding element --| of List2 has the same value. This function uses the Equal operation --| provided by the user. If one is not provided then = is used. ------------------------------------------------------------------------------ private type Cell; type List is access Cell; --| pointer added by this package --| in order to make a list type Cell is --| Cell for the lists being created record Info: Tree; Next: List; end record; type ListIter is new List; --| This prevents Lists being assigned to --| iterators and vice versa end NodeOrder; type TreeIter is record NodeList :NodeOrder.List; State :NodeOrder.ListIter; end record; end TreePkg; type Set is record SetRep :TreePkg.Tree; end record; type SetIter is record Place :TreePkg.TreeIter; Count :natural; end record; end Literal_Set; -- package Literal_Set is new OrderedSets -- (ItemType => Source_Text.Locator, "<" => "<" ); -- generic -- type ItemType is private; -- with function "<" ( X ,Y: in ItemType) return boolean; type BlockInfoType is record TokenCount :TokenCountType; BlockId :BlockIdType; SetOfLiterals :Literal_Set.Set; SetOfDEF_IDs :DEF_ID_Set.Set; end record; --| This is the information which pertains to a particular block --| of the source program. This information is pushed on --| a stack when an new block is encountered. The --| information is a count of the tokens encountered so far --| and the DEF_ID's which have been found as well as the --| identifying information for the block. The ListOfLiterals --| is a list of all literals encounter --? package BlockInfoStack is new Stacks(BlockInfoType); --? use StackBlockInfo; package BlockInfoStack is type stack is private; --| The stack abstract data type. uninitialized_stack: exception; --| The initialization operations are create and copy. empty_stack: exception; function create return stack; procedure push(s: in out stack; e: BlockInfoType); procedure pop(s: in out stack); procedure pop(s: in out stack; e: out BlockInfoType); function copy(s: stack) return stack; function top(s: stack) return BlockInfoType; function size(s: stack) return natural; function is_empty(s: stack) return boolean; procedure destroy(s: in out stack); private package Lists is type List is private; type ListIter is private; CircularList :exception; --| Raised if an attemp is made to --| create a circular list. This --| results when a list is attempted --| to be attached to itself. EmptyList :exception; --| Raised if an attemp is made to --| manipulate an empty list. ItemNotPresent :exception; --| Raised if an attempt is made to --| remove an element from a list in --| which it does not exist. NoMore :exception; --| Raised if an attemp is made to --| get the next element from a list --| after iteration is complete. procedure Attach( --| appends List2 to List1 List1: in out List; --| The list being appended to. List2: in List --| The list being appended. ); function Attach( --| Creates a new list containing the two --| Elements. Element1: in BlockInfoType; --| This will be first element in list. Element2: in BlockInfoType --| This will be second element in list. ) return List; procedure Attach( --| List L is appended with Element. L: in out List; --| List being appended to. Element: in BlockInfoType --| This will be last element in l ist. ); procedure Attach( --| Makes Element first item in list L. Element: in BlockInfoType; --| This will be the first element in list. L: in out List --| The List which Element is being --| prepended to. ); function Attach ( --| attaches two lists List1: in List; --| first list List2: in List --| second list ) return List; function Attach ( --| prepends an element onto a list Element: in BlockInfoType; --| element being prepended to list L: in List --| List which element is being added --| to ) return List; function Attach ( --| Adds an element to the end of a list L: in List; --| The list which element is being added to. Element: in BlockInfoType --| The element being added to the end of --| the list. ) return List; function Copy( --| returns a copy of list1 L: in List --| list being copied ) return List; function Create --| Returns an empty List return List; procedure DeleteHead( --| Remove the head element from a list. L: in out List --| The list whose head is being removed. ); procedure DeleteItem( --| remove the first occurrence of Element --| from L L: in out List; --| list element is being removed from Element: in BlockInfoType --| element being removed ); procedure DeleteItems( --| remove all occurrences of Element --| from L. L: in out List; --| The List element is being removed from Element: in BlockInfoType --| element being removed ); procedure Destroy( --| removes the list L: in out List --| the list being removed ); function FirstValue( --| returns the contents of the first record of the --| list L: in List --| the list whose first element is being --| returned ) return BlockInfoType; function IsEmpty( --| Checks if a list is empty. L: in List --| List being checked. ) return boolean; function IsInList( --| Checks if element is an element of --| list. L: in List; --| list being scanned for element Element: in BlockInfoType --| element being searched for ) return boolean; function LastValue( --| Returns the contents of the last record of --| the list. L: in List --| The list whose first element is being --| returned. ) return BlockInfoType; function Length( --| count the number of elements on a list L: in List --| list whose length is being computed ) return integer; function MakeListIter( --| Sets a variable to point to the head --| of the list. This will be used to --| prepare for iteration over a list. L: in List --| The list being iterated over. ) return ListIter; function More( --| Returns true if there are more elements in --| the and false if there aren't any more --| the in the list. L: in ListIter --| List being checked for elements. ) return boolean; procedure Next( --| This is the iterator operation. Given --| a ListIter in the list it returns the --| current item and updates the ListIter. --| If ListIter is at the end of the list, --| More returns false otherwise it --| returns true. Place: in out ListIter; --| The Iter which marks the position in --| the list. Info: out BlockInfoType --| The element being returned. ); procedure ReplaceHead( --| Replace the Item at the head of the list --| with the parameter Item. L: in out List; --| The list being modified. Info: in BlockInfoType --| The information being entered. ); procedure ReplaceTail( --| Replace the Tail of a list --| with a new list. L: in out List; --| List whose Tail is replaced. NewTail: in List --| The list which will become the --| tail of Oldlist. ); function Tail( --| returns the tail of a list L L: in List --| the list whose tail is being returned ) return List; function Equal( --| compares list1 and list2 for equality List1: in List; --| first list List2: in List --| second list ) return boolean; private type Cell; type List is access Cell; --| pointer added by this package --| in order to make a list type Cell is --| Cell for the lists being created record Info: BlockInfoType; Next: List; end record; type ListIter is new List; --| This prevents Lists being assigned to --| iterators and vice versa end Lists; subtype elem_list is lists.list; type stack_rec is record size: natural := 0; elts: elem_list; end record; type stack is access stack_rec; end BlockInfoStack; end Definitions; :::::::::::::: halstead.ada :::::::::::::: -------SPEC--------------------------------------------------------------- function Halstead return INTEGER; -------BODY--------------------------------------------------------------- with STRING_LISTS; with COMMANDLINE; with STANDARD_INTERFACE; with STRING_PKG; with TEXT_IO; use TEXT_IO; with HOST_LIB; with ST_DIANA; with PROGRAMLIBRARY; with COMP_UNIT_CLASS_PKG; with DEFINITIONS; with HALSTEAD_DATA_BASE; --xx with FILE_MANAGER; function Halstead return INTEGER is package CL renames COMMANDLINE; package SI renames STANDARD_INTERFACE; package SL renames STRING_LISTS; package SP renames STRING_PKG; package D renames DEFINITIONS; package PL renames PROGRAMLIBRARY; package HDB renames HALSTEAD_DATA_BASE; --xx package FM renames FILE_MANAGER; package STRINGTYPE is new SI.STRING_ARGUMENT("string"); package UNIT_LIST_PKG is new SI.STRING_LIST_ARGUMENT( STRING_TYPE_NAME => "string_type", STRING_TYPE_LIST => "string_list"); dd_name : string(1..200); dd_Last : natural; dd_changed : boolean; pl_name : string(1..200); pl_last : natural; HALSTEAD : SI.PROCESS_HANDLE; library_Name : SP.string_type; OUTPUT_FILE: FILE_TYPE; output_File_Name : sp.string_type; unit_list : SL.LIST; ITER : SL.LISTITER; unit_Name : sp.string_type; ToTerminal : boolean; verbose : boolean; Unit_SD : PL.Subdomain_Type; COMP_UNIT_Locator: ST_DIANA.COMP_UNIT_CLASS.Locator; UnitPosition : natural := 1; begin -- driver HOST_LIB.SET_ERROR; SI.set_tool_identifier ("1.0"); STANDARD_INTERFACE.DEFINE_PROCESS(PROC => Halstead, NAME => "Halstead", HELP => "Computes Halstead formulas for Ada compilation units."); UNIT_LIST_PKG.DEFINE_ARGUMENT(PROC => HALSTEAD, NAME => "Units", DEFAULT => SL.CREATE, HELP => "Names of the compilation units"); Stringtype.DEFINE_ARGUMENT(PROC => halstead, NAME => "Output", DEFAULT => "", HELP => "Name of the report file (defaults to standard output)"); STRINGTYPE.DEFINE_ARGUMENT(PROC => HALSTEAD, NAME => "library", DEFAULT => "[.BYRONLIB]", Help => "Name of an Ada program library (NYI)"); SI.DEFINE_PROCESS_HELP(PROC => halstead, HELP => "Computes Halstead formulas for Ada compilation units"); STANDARD_INTERFACE.PARSE_LINE(halstead); unit_list := unit_LIST_pkg.GET_ARGUMENT(PROC => halstead, NAME => "units"); library_Name := stringtype.get_argument(proc => halstead, name => "library"); output_File_Name := STRINGTYPE.GET_ARGUMENT(PROC => halstead, NAME => "output"); verbose := FALSE; if sp.equal(output_File_Name, "") then -- No file name given: output is to the terminal Set_Output(STANDARD_OUTPUT); ToTerminal := true; else -- Create the specified output file create(File => Output_File, Mode => Out_File, Name => sp.value(output_File_Name), Form => "" ); Set_Output(Output_File); ToTerminal := false; end if; -- Connect to the program library directory: --xx FM.Show_and_Set_Default(dd_name,dd_last,dd_changed,SP.Value(library_Name)); --xx if not dd_changed then --xx Put_Line("?? Cannot connect to program library."); --xx return HOST_LIB.RETURN_CODE(HOST_LIB.ERROR); --xx end if; -- Open the catalog. This is the program library which contains -- the library units which the user is performing the Halstead -- Complexity Measures on. PL.Open_catalog; ST_DIANA.NEWDOMAIN (PL.Get_Primary_Context, PL.Get_Secondary_Context); -- Get each library unit which the user is performing the metric on. -- For each unit get its COMP_UNIT_CLASS.Locator which is the handle -- to the beginning of the DIANA for the unit. Pass the Locator -- to the bonsai tree walk routine which computes the metrics. ITER := SL.MAKELISTITER(UNIT_LIST); while SL.MORE(ITER) loop SL.next(iter, unit_Name); -- Check to see if the unit specified is a SubUnit. if cl.IsSubUnit(SP.Value(unit_Name), unitposition) then begin Unit_SD := PL.Open_Subdomain( ST_Diana.TheDomain, PL.DIANA_Form, PL.SubUnit_Ident ( CL.GetParent (sp.value(unit_Name), UnitPosition) , CL.GetSubUnit (sp.value(unit_Name), UnitPosition), IsStub => false )); exception when PL.Object_Not_Up_To_Date => Put(Standard_Output, "%% WARNING: "); Put(Standard_Output, "Subunit " & SP.Value(unit_Name)); Put_Line(Standard_Output, " not found"); end; -- Pass the necessary data to the Utilities package. HDB.InitializeData( LibraryUnit => SP.Value(unit_Name), IsUnitSpec => false, VerboseFlag => Verbose, ToTerminalFlag => ToTerminal, OuterMostBlockFlag => false ); -- If writing to an output file then generate a -- report header. If writing to the terminal a header is -- generated in the utilities package. if not ToTerminal then HDB.ReportHeader (SP.Value(unit_Name), Spec => false); end if; -- Get the actual locator for the library unit. COMP_UNIT_Locator := ST_Diana.Comp_UnitNode.GetRoot (Unit_SD); -- Now that we have the locator scan the diana which -- the locator points to. COMP_UNIT_CLASS_Pkg.Scan_Comp_Unit_Class(COMP_UNIT_Locator); else -- For any library unit which is not a subunit this -- loop scans both the specification (implicit as well -- as explicit) and the body of the unit. for IsSpec in reverse false..true loop -- Open the Subdomain. begin Unit_SD := PL.Open_Subdomain( ST_Diana.TheDomain, PL.DIANA_Form, PL.Library_Unit_Ident ( SP.Value(unit_Name), IsSpec )); -- Pass the data to the utilities package. HDB.InitializeData( LibraryUnit => SP.Value(unit_Name), IsUnitSpec => IsSpec, VerboseFlag => Verbose, ToTerminalFlag => ToTerminal, OuterMostBlockFlag => false ); if not ToTerminal then HDB.ReportHeader (SP.Value(unit_Name), IsSpec); end if; -- Get the locator to the library unit. COMP_UNIT_Locator := ST_Diana.Comp_UnitNode.GetRoot (Unit_SD); -- Perform the scan on the diana which the locator points to. COMP_UNIT_CLASS_Pkg.Scan_Comp_Unit_Class(COMP_UNIT_Locator); -- Catch the exception when attempting to open either -- implicit spec or body. exception when PL.Object_Not_Up_To_Date => Put_Line(Standard_Output, "%% WARNING: "); if IsSpec then Put(Standard_Output, "The spec of "); else Put(Standard_Output, "The body of "); end if; Put(Standard_Output, "Unit " & SP.Value(unit_Name)); Put_Line(Standard_Output, " does not exist"); end; end loop; end if; end loop; --xx FM.Show_and_Set_Default(pl_name, pl_last, dd_changed, dd_name(1..dd_last)); return HOST_LIB.RETURN_CODE(HOST_LIB.SUCCESS); exception when STANDARD_INTERFACE.PROCESS_HELP => return HOST_LIB.RETURN_CODE(HOST_LIB.INFORMATION); when STANDARD_INTERFACE.ABORT_PROCESS => return HOST_LIB.RETURN_CODE(HOST_LIB.ERROR); -- when others => -- TEXT_IO.PUT_LINE("internal error"); -- return HOST_LIB.RETURN_CODE(HOST_LIB.ERROR); end Halstead; :::::::::::::: halstead.obj :::::::::::::: ADA$ELAB_HALSTEAD01 4-Mar-1986 08:55 VAX Ada V1.1-10y< nADA$ELAB_HALSTEAD}>nADA$ELAB_HALSTEADPHALSTEADSTRING_LISTSSTRING_PKG_ STRING_PKGLISTSCOMMANDLINE_COMMANDLINESTANDARD_INTERFACE_STANDARD_INTERFACEINTEGER_LISTSPAGINATED_OUTPUT_PAGINATED_OUTPUTTEXT_IO_TEXT_IOIO_EXCEPTIONS_ HOST_LIB_HOST_LIB ST_DIANA_ST_DIANAML_SOURCE_POSITION_PKG_ML_SOURCE_POSITION_PKGFE_TEMPORARY_ATTRIBUTES_ML_MACHINE_DATA_PKG_TGT_ML_TARGET_CONSTANTS_TGT_ML_TARGET_CONSTANTSML_STORAGE_DIMENSION_PKG_ML_STORAGE_DIMENSION_PKGVMMTEXTPKG_ VMMTEXTPKGVMMSYSTEMPKG_VMMSYSTEMPKGML_VMM_LOCATOR_PKG_VSUTILS_VSUTILSVSDECLARATIONS_VMMBASICPKG_VMMBASICPKGPAGE_IO DIRECT_IOVMMPAGE_HIF_NODE_DEFS_ HIF_DEFS_HIF_FAKE_NODE_HANDLES_HIF_FAKE_NODE_HANDLESHIF_LIST_UTILS_HIF_LIST_UTILSHIF_TEXT_UTILS_HIF_TEXT_UTILSVMMTYPESPKG_VMMTYPESPKGPROGRAMLIBRARY_PROGRAMLIBRARYHIF_HOST_FILE_MANAGEMENT_HIF_HOST_FILE_MANAGEMENTHIF_HOST_FILE_DEFS_PLIF_UTILS_ PLIF_UTILSLIBRARY_CATALOG_DEFS_LIBRARY_COMPILATION_MANAGER_LIBRARY_COMPILATION_MANAGERHIF_NODE_MANAGEMENT_HIF_NODE_MANAGEMENTHIF_SIMPLE_OBJECT_MANAGER_HIF_SIMPLE_OBJECT_MANAGERHIF_RELATIONSHIP_NAMES_HIF_RELATIONSHIP_NAMESHIF_STRINGS_HIF_STRINGSHIF_IDENTIFIERS_HIF_IDENTIFIERSHIF_PARTITION_MANAGER_HIF_PARTITION_MANAGERHIF_PARTITION_ELEMENTS_HIF_PARTITION_ELEMENTSHOST_BIN_KEYED_IO_TYPES_HIF_KEYED_IO_DEFS_RELATIVE_IOAUX_IO_EXCEPTIONS_HIF_PARTITION_MAPPING_HIF_PARTITION_MAPPINGHIF_KEYED_IO_HIF_KEYED_IOBIN_KEYED_IO_BLOCKS_BIN_KEYED_IO_BLOCKSHOST_PAGE_IO_HOST_PAGE_IOBIN_KEYED_IO_UTILITIES_BIN_KEYED_IO_UTILITIESHIF_IDENTIFIER_PATTERNS_HIF_IDENTIFIER_PATTERNSLIBRARY_UNIT_DEFS_LIBRARY_IDENTIFICATION_MANAGER_LIBRARY_IDENTIFICATION_MANAGERLIBRARY_IDENT_MANAGER_LIBRARY_IDENT_MANAGERCOMP_UNIT_CLASS_PKG_COMP_UNIT_CLASS_PKGDEFINITIONS_DEFINITIONSHALSTEAD_DATA_BASE_HALSTEAD_DATA_BASESTRING_UTILITIES_STRING_UTILITIES STACK_PKGSET_PKGADA$U008E7F1B30B92E00_00000097ADA$U008E7F1B30B92E00_0000009AINT_IO CALENDAR_CALENDARSTARLET_CONDITION_HANDLING_CONDITION_HANDLINGT_370_ML_TARGET_CONSTANTS_T_1750A_ML_TARGET_CONSTANTS_T_PRIME_ML_TARGET_CONSTANTS_T_SPERRY_ML_TARGET_CONSTANTS_TGT_ML_TARGET_SWITCH_TGT_ML_TARGET_SWITCH HIF_DEBUG_ HIF_DEBUGPARAMETERS_ PARAMETERSPLIF_DEBUG_ PLIF_DEBUGADA$U008E192A5B0FDC00_00000502LIBRARY_CONFIGURATION_INTERFACELIBRARY_COLLECTION_DEFS_LIBRARY_DEPENDENCY_MANAGER_LIBRARY_DEPENDENCY_MANAGERHIF_NODE_HANDLES_HIF_NODE_HANDLESHOST_SYSTEM_CALLS_HOST_SYSTEM_CALLSHIF_PRS_ATTRIBUTES_HIF_PRS_ATTRIBUTESPLIF_NAME_DEFS_HIF_PATH_NAMES_HIF_PATH_NAMESHIF_ATTRIBUTES_HIF_ATTRIBUTESHIF_KEY_GENERATOR_HIF_KEY_GENERATORHIF_KEYED_IO_LOCALS_HIF_KEYED_IO_LOCALSHIF_RELATIVE_PATHS_PLIF_ATTRIBUTE_NAMES_ ITEM_PKG_ITEM_PKGCOUNT_TYPES_COUNT_TYPESCOUNT_COUNTBOOTOPTIONS_BOOTOPTIONSPLIF_DEPENDENCY_UTILS_PLIF_DEPENDENCY_UTILSHIF_BIG_ATTRIBUTES_HIF_BIG_ATTRIBUTESUP_TO_DATE_CACHE_PKG_UP_TO_DATE_CACHE_PKGHIF_NODE_INFO_DIOSERIES_UNIT_IH_VARIABLE_DECL_IH_SUBTYPE_DECL_IH_TASK_DECL_IH_TYPE_DECL_IH_GENERIC_HEADER_CLASS_PKG_GENERIC_HEADER_CLASS_PKGDEF_ID_PKG_ DEF_ID_PKGPKG_DEF_PKG_PKG_DEF_PKGHEADER_PKG_ HEADER_PKGOBJECT_TYPE_PKG_OBJECT_TYPE_PKGOBJECT_DEF_PKG_OBJECT_DEF_PKGNAME_EXP_PKG_NAME_EXP_PKGCONSTRAINT_PKG_CONSTRAINT_PKGSUBP_DEF_PKG_SUBP_DEF_PKGGENERAL_ASSOC_PKG_GENERAL_ASSOC_PKGBLOCK_STUB_PKG_BLOCK_STUB_PKGTYPE_SPEC_PKG_TYPE_SPEC_PKGGENERIC_HEADER_IH_IDENTIFIER_UTILITIES_IDENTIFIER_UTILITIESAGG_COMPONENT_PKG_AGG_COMPONENT_PKGSTM_PKG_STM_PKGALTERNATIVE_PKG_ALTERNATIVE_PKGBLOCK_STM_IH_SOURCE_POSITION_UTILITIES_SOURCE_POSITION_UTILITIESINNER_RECORD_CLASS_PKG_INNER_RECORD_CLASS_PKGAGG_NAMED_IH_CHOICE_PKG_ CHOICE_PKGITERATION_PKG_ITERATION_PKGBLOCK_UTILITIES_BLOCK_UTILITIESCASE_ALTERNATIVE_IH_HANDLER_ALTERNATIVE_IH_INNER_RECORD_IH_VARIANT_ALTERNATIVE_CLASS_PKG_VARIANT_ALTERNATIVE_CLASS_PKGVMMADDRESSARITHMETIC_VMMADDRESSARITHMETICPLIF_OBJECT_COUNT_UTILS_PLIF_OBJECT_COUNT_UTILS ADA$ELAB_HALSTEAD|{ HALSTEADHALSTEADw/ ]\{ADA$INIT_COMPONENT~P LISTS$ELAB LISTS$ELAB IO_EXCEPTIONS_$ELABIO_EXCEPTIONS_$ELAB ML_SOURCE_POSITION_PKG_$ELABML_SOURCE_POSITION_PKG_$ELAB ML_SOURCE_POSITION_PKG$ELABML_SOURCE_POSITION_PKG$ELAB FE_TEMPORARY_ATTRIBUTES_$ELABFE_TEMPORARY_ATTRIBUTES_$ELAB ML_VMM_LOCATOR_PKG_$ELABML_VMM_LOCATOR_PKG_$ELAB "VSDECLARATIONS_$ELAB"VSDECLARATIONS_$ELAB 'VMMPAGE_$ELAB'VMMPAGE_$ELAB )HIF_DEFS_$ELAB)HIF_DEFS_$ELAB *HIF_FAKE_NODE_HANDLES_$ELAB*HIF_FAKE_NODE_HANDLES_$ELAB +HIF_FAKE_NODE_HANDLES$ELAB+HIF_FAKE_NODE_HANDLES$ELAB BHIF_STRINGS_$ELABBHIF_STRINGS_$ELAB CHIF_STRINGS$ELABCHIF_STRINGS$ELAB MAUX_IO_EXCEPTIONS_$ELABMAUX_IO_EXCEPTIONS_$ELAB iADA$U008E7F1B30B92E00_00000097$iADA$U008E7F1B30B92E00_00000097$ jADA$U008E7F1B30B92E00_0000009A$jADA$U008E7F1B30B92E00_0000009A$ oCONDITION_HANDLING_$ELABoCONDITION_HANDLING_$ELAB pCONDITION_HANDLING$ELABpCONDITION_HANDLING$ELAB qT_370_ML_TARGET_CONSTANTS_$ELABqT_370_ML_TARGET_CONSTANTS_$ELAB rT_1750A_ML_TARGET_CONSTANTS_$ELrT_1750A_ML_TARGET_CONSTANTS_$EL sT_PRIME_ML_TARGET_CONSTANTS_$ELsT_PRIME_ML_TARGET_CONSTANTS_$EL tT_SPERRY_ML_TARGET_CONSTANTS_$EtT_SPERRY_ML_TARGET_CONSTANTS_$E HIF_KEY_GENERATOR_$ELABHIF_KEY_GENERATOR_$ELAB HIF_KEY_GENERATOR$ELABHIF_KEY_GENERATOR$ELAB gSTACK_PKG$ELABgSTACK_PKG$ELAB INTEGER_LISTS$ELAB INTEGER_LISTS$ELAB hSET_PKG$ELABhSET_PKG$ELAB &DIRECT_IO$ELAB&DIRECT_IO$ELAB TEXT_IO_$ELABTEXT_IO_$ELAB TEXT_IO$ELABTEXT_IO$ELAB JSOURCE_POSITION_UTILITIES_$ELABJSOURCE_POSITION_UTILITIES_$ELAB KSOURCE_POSITION_UTILITIES$ELABKSOURCE_POSITION_UTILITIES$ELAB ZVMMADDRESSARITHMETIC_$ELABZVMMADDRESSARITHMETIC_$ELAB [VMMADDRESSARITHMETIC$ELAB[VMMADDRESSARITHMETIC$ELAB KHIF_KEYED_IO_DEFS_$ELABKHIF_KEYED_IO_DEFS_$ELAB 6HIF_HOST_FILE_DEFS_$ELAB6HIF_HOST_FILE_DEFS_$ELAB (HIF_NODE_DEFS_$ELAB(HIF_NODE_DEFS_$ELAB DHIF_IDENTIFIERS_$ELABDHIF_IDENTIFIERS_$ELAB EHIF_IDENTIFIERS$ELABEHIF_IDENTIFIERS$ELAB LRELATIVE_IO$ELABLRELATIVE_IO$ELAB nSTARLET_$ELABnSTARLET_$ELAB STRING_PKG_$ELABSTRING_PKG_$ELAB STRING_PKG$ELABSTRING_PKG$ELAB "DIO$ELAB"DIO$ELAB %PAGE_IO$ELAB%PAGE_IO$ELAB kINT_IO$ELABkINT_IO$ELAB .HIF_TEXT_UTILS_$ELAB.HIF_TEXT_UTILS_$ELAB /HIF_TEXT_UTILS$ELAB/HIF_TEXT_UTILS$ELAB VMMTEXTPKG_$ELABVMMTEXTPKG_$ELAB VMMTEXTPKG$ELABVMMTEXTPKG$ELAB PLIF_ATTRIBUTE_NAMES_$ELABPLIF_ATTRIBUTE_NAMES_$ELAB PLIF_NAME_DEFS_$ELABPLIF_NAME_DEFS_$ELAB XHIF_IDENTIFIER_PATTERNS_$ELABXHIF_IDENTIFIER_PATTERNS_$ELAB YHIF_IDENTIFIER_PATTERNS$ELABYHIF_IDENTIFIER_PATTERNS$ELAB @HIF_RELATIONSHIP_NAMES_$ELAB@HIF_RELATIONSHIP_NAMES_$ELAB AHIF_RELATIONSHIP_NAMES$ELABAHIF_RELATIONSHIP_NAMES$ELAB JHOST_BIN_KEYED_IO_TYPES_$ELABJHOST_BIN_KEYED_IO_TYPES_$ELAB lCALENDAR_$ELABlCALENDAR_$ELAB mCALENDAR$ELABmCALENDAR$ELAB STRING_LISTS$ELABSTRING_LISTS$ELAB COMMANDLINE_$ELABCOMMANDLINE_$ELAB COMMANDLINE$ELABCOMMANDLINE$ELAB BOOTOPTIONS_$ELABBOOTOPTIONS_$ELAB BOOTOPTIONS$ELABBOOTOPTIONS$ELAB ZLIBRARY_UNIT_DEFS_$ELABZLIBRARY_UNIT_DEFS_$ELAB VSUTILS_$ELAB VSUTILS_$ELAB !VSUTILS$ELAB!VSUTILS$ELAB eSTRING_UTILITIES_$ELABeSTRING_UTILITIES_$ELAB fSTRING_UTILITIES$ELABfSTRING_UTILITIES$ELAB HOST_SYSTEM_CALLS_$ELABHOST_SYSTEM_CALLS_$ELAB HOST_SYSTEM_CALLS$ELABHOST_SYSTEM_CALLS$ELAB yPARAMETERS_$ELAByPARAMETERS_$ELAB zPARAMETERS$ELABzPARAMETERS$ELAB VMMSYSTEMPKG_$ELABVMMSYSTEMPKG_$ELAB VMMSYSTEMPKG$ELABVMMSYSTEMPKG$ELAB HOST_LIB_$ELABHOST_LIB_$ELAB HOST_LIB$ELABHOST_LIB$ELAB PAGINATED_OUTPUT_$ELAB PAGINATED_OUTPUT_$ELAB PAGINATED_OUTPUT$ELABPAGINATED_OUTPUT$ELAB {PLIF_DEBUG_$ELAB{PLIF_DEBUG_$ELAB |PLIF_DEBUG$ELAB|PLIF_DEBUG$ELAB wHIF_DEBUG_$ELABwHIF_DEBUG_$ELAB xHIF_DEBUG$ELABxHIF_DEBUG$ELAB uTGT_ML_TARGET_SWITCH_$ELABuTGT_ML_TARGET_SWITCH_$ELAB vTGT_ML_TARGET_SWITCH$ELABvTGT_ML_TARGET_SWITCH$ELAB STANDARD_INTERFACE_$ELABSTANDARD_INTERFACE_$ELAB STANDARD_INTERFACE$ELABSTANDARD_INTERFACE$ELAB ]LIBRARY_IDENT_MANAGER_$ELAB]LIBRARY_IDENT_MANAGER_$ELAB ^LIBRARY_IDENT_MANAGER$ELAB^LIBRARY_IDENT_MANAGER$ELAB THOST_PAGE_IO_$ELABTHOST_PAGE_IO_$ELAB UHOST_PAGE_IO$ELABUHOST_PAGE_IO$ELAB HIF_PATH_NAMES_$ELAB HIF_PATH_NAMES_$ELAB HIF_PATH_NAMES$ELAB HIF_PATH_NAMES$ELAB HHIF_PARTITION_ELEMENTS_$ELABHHIF_PARTITION_ELEMENTS_$ELAB IHIF_PARTITION_ELEMENTS$ELABIHIF_PARTITION_ELEMENTS$ELAB ,HIF_LIST_UTILS_$ELAB,HIF_LIST_UTILS_$ELAB -HIF_LIST_UTILS$ELAB-HIF_LIST_UTILS$ELAB TGT_ML_TARGET_CONSTANTS_$ELABTGT_ML_TARGET_CONSTANTS_$ELAB TGT_ML_TARGET_CONSTANTS$ELABTGT_ML_TARGET_CONSTANTS$ELAB RBIN_KEYED_IO_BLOCKS_$ELABRBIN_KEYED_IO_BLOCKS_$ELAB SBIN_KEYED_IO_BLOCKS$ELABSBIN_KEYED_IO_BLOCKS$ELAB LIBRARY_COLLECTION_DEFS_$ELABLIBRARY_COLLECTION_DEFS_$ELAB 9LIBRARY_CATALOG_DEFS_$ELAB9LIBRARY_CATALOG_DEFS_$ELAB ML_STORAGE_DIMENSION_PKG_$ELABML_STORAGE_DIMENSION_PKG_$ELAB ML_STORAGE_DIMENSION_PKG$ELABML_STORAGE_DIMENSION_PKG$ELAB ML_MACHINE_DATA_PKG_$ELABML_MACHINE_DATA_PKG_$ELAB VBIN_KEYED_IO_UTILITIES_$ELABVBIN_KEYED_IO_UTILITIES_$ELAB WBIN_KEYED_IO_UTILITIES$ELABWBIN_KEYED_IO_UTILITIES$ELAB HIF_KEYED_IO_LOCALS_$ELABHIF_KEYED_IO_LOCALS_$ELAB HIF_KEYED_IO_LOCALS$ELABHIF_KEYED_IO_LOCALS$ELAB PHIF_KEYED_IO_$ELABPHIF_KEYED_IO_$ELAB QHIF_KEYED_IO$ELABQHIF_KEYED_IO$ELAB NHIF_PARTITION_MAPPING_$ELABNHIF_PARTITION_MAPPING_$ELAB OHIF_PARTITION_MAPPING$ELABOHIF_PARTITION_MAPPING$ELAB FHIF_PARTITION_MANAGER_$ELABFHIF_PARTITION_MANAGER_$ELAB GHIF_PARTITION_MANAGER$ELABGHIF_PARTITION_MANAGER$ELAB >HIF_SIMPLE_OBJECT_MANAGER_$ELAB>HIF_SIMPLE_OBJECT_MANAGER_$ELAB ?HIF_SIMPLE_OBJECT_MANAGER$ELAB?HIF_SIMPLE_OBJECT_MANAGER$ELAB !HIF_NODE_INFO_$ELAB!HIF_NODE_INFO_$ELAB HIF_PRS_ATTRIBUTES_$ELABHIF_PRS_ATTRIBUTES_$ELAB HIF_PRS_ATTRIBUTES$ELABHIF_PRS_ATTRIBUTES$ELAB HIF_NODE_HANDLES_$ELABHIF_NODE_HANDLES_$ELAB HIF_NODE_HANDLES$ELABHIF_NODE_HANDLES$ELAB #VMMBASICPKG_$ELAB#VMMBASICPKG_$ELAB 4HIF_HOST_FILE_MANAGEMENT_$ELAB4HIF_HOST_FILE_MANAGEMENT_$ELAB 7PLIF_UTILS_$ELAB7PLIF_UTILS_$ELAB <HIF_NODE_MANAGEMENT_$ELAB<HIF_NODE_MANAGEMENT_$ELAB HIF_ATTRIBUTES_$ELABHIF_ATTRIBUTES_$ELAB PLIF_DEPENDENCY_UTILS_$ELABPLIF_DEPENDENCY_UTILS_$ELAB HIF_BIG_ATTRIBUTES_$ELABHIF_BIG_ATTRIBUTES_$ELAB UP_TO_DATE_CACHE_PKG_$ELABUP_TO_DATE_CACHE_PKG_$ELAB 0VMMTYPESPKG_$ELAB0VMMTYPESPKG_$ELAB 1VMMTYPESPKG$ELAB1VMMTYPESPKG$ELAB HIF_RELATIVE_PATHS_$ELABHIF_RELATIVE_PATHS_$ELAB :LIBRARY_COMPILATION_MANAGER_$EL:LIBRARY_COMPILATION_MANAGER_$EL ;LIBRARY_COMPILATION_MANAGER$ELA;LIBRARY_COMPILATION_MANAGER$ELA 8PLIF_UTILS$ELAB8PLIF_UTILS$ELAB 5HIF_HOST_FILE_MANAGEMENT$ELAB5HIF_HOST_FILE_MANAGEMENT$ELAB \PLIF_OBJECT_COUNT_UTILS_$ELAB\PLIF_OBJECT_COUNT_UTILS_$ELAB ]PLIF_OBJECT_COUNT_UTILS$ELAB]PLIF_OBJECT_COUNT_UTILS$ELAB $VMMBASICPKG$ELAB$VMMBASICPKG$ELAB }ADA$U008E192A5B0FDC00_00000502$}ADA$U008E192A5B0FDC00_00000502$ ~LIBRARY_CONFIGURATION_INTERFACE~LIBRARY_CONFIGURATION_INTERFACE =HIF_NODE_MANAGEMENT$ELAB=HIF_NODE_MANAGEMENT$ELAB HIF_ATTRIBUTES$ELABHIF_ATTRIBUTES$ELAB PLIF_DEPENDENCY_UTILS$ELABPLIF_DEPENDENCY_UTILS$ELAB HIF_BIG_ATTRIBUTES$ELABHIF_BIG_ATTRIBUTES$ELAB UP_TO_DATE_CACHE_PKG$ELAB UP_TO_DATE_CACHE_PKG$ELAB ST_DIANA_$ELABST_DIANA_$ELAB ST_DIANA$ELABST_DIANA$ELAB WINNER_RECORD_IH_$ELABWINNER_RECORD_IH_$ELAB VHANDLER_ALTERNATIVE_IH_$ELABVHANDLER_ALTERNATIVE_IH_$ELAB UCASE_ALTERNATIVE_IH_$ELABUCASE_ALTERNATIVE_IH_$ELAB SBLOCK_UTILITIES_$ELABSBLOCK_UTILITIES_$ELAB TBLOCK_UTILITIES$ELABTBLOCK_UTILITIES$ELAB NAGG_NAMED_IH_$ELABNAGG_NAMED_IH_$ELAB IBLOCK_STM_IH_$ELABIBLOCK_STM_IH_$ELAB AIDENTIFIER_UTILITIES_$ELABAIDENTIFIER_UTILITIES_$ELAB BIDENTIFIER_UTILITIES$ELABBIDENTIFIER_UTILITIES$ELAB @GENERIC_HEADER_IH_$ELAB@GENERIC_HEADER_IH_$ELAB 'TYPE_DECL_IH_$ELAB'TYPE_DECL_IH_$ELAB &TASK_DECL_IH_$ELAB&TASK_DECL_IH_$ELAB %SUBTYPE_DECL_IH_$ELAB%SUBTYPE_DECL_IH_$ELAB $VARIABLE_DECL_IH_$ELAB$VARIABLE_DECL_IH_$ELAB #SERIES_UNIT_IH_$ELAB#SERIES_UNIT_IH_$ELAB aDEFINITIONS_$ELABaDEFINITIONS_$ELAB bDEFINITIONS$ELABbDEFINITIONS$ELAB COUNT_TYPES_$ELABCOUNT_TYPES_$ELAB COUNT_TYPES$ELABCOUNT_TYPES$ELAB COUNT_$ELABCOUNT_$ELAB COUNT$ELAB COUNT$ELAB cHALSTEAD_DATA_BASE_$ELABcHALSTEAD_DATA_BASE_$ELAB dHALSTEAD_DATA_BASE$ELABdHALSTEAD_DATA_BASE$ELAB *DEF_ID_PKG_$ELAB*DEF_ID_PKG_$ELAB +DEF_ID_PKG$ELAB+DEF_ID_PKG$ELAB [LIBRARY_IDENTIFICATION_MANAGER_[LIBRARY_IDENTIFICATION_MANAGER_ _COMP_UNIT_CLASS_PKG_$ELAB_COMP_UNIT_CLASS_PKG_$ELAB LIBRARY_DEPENDENCY_MANAGER_$ELALIBRARY_DEPENDENCY_MANAGER_$ELA ITEM_PKG_$ELABITEM_PKG_$ELAB (GENERIC_HEADER_CLASS_PKG_$ELAB(GENERIC_HEADER_CLASS_PKG_$ELAB ,PKG_DEF_PKG_$ELAB,PKG_DEF_PKG_$ELAB .HEADER_PKG_$ELAB.HEADER_PKG_$ELAB 0OBJECT_TYPE_PKG_$ELAB0OBJECT_TYPE_PKG_$ELAB 2OBJECT_DEF_PKG_$ELAB2OBJECT_DEF_PKG_$ELAB 4NAME_EXP_PKG_$ELAB4NAME_EXP_PKG_$ELAB 6CONSTRAINT_PKG_$ELAB6CONSTRAINT_PKG_$ELAB 8SUBP_DEF_PKG_$ELAB8SUBP_DEF_PKG_$ELAB :GENERAL_ASSOC_PKG_$ELAB:GENERAL_ASSOC_PKG_$ELAB <BLOCK_STUB_PKG_$ELAB<BLOCK_STUB_PKG_$ELAB >TYPE_SPEC_PKG_$ELAB>TYPE_SPEC_PKG_$ELAB CAGG_COMPONENT_PKG_$ELABCAGG_COMPONENT_PKG_$ELAB ESTM_PKG_$ELABESTM_PKG_$ELAB GALTERNATIVE_PKG_$ELABGALTERNATIVE_PKG_$ELAB LINNER_RECORD_CLASS_PKG_$ELABLINNER_RECORD_CLASS_PKG_$ELAB OCHOICE_PKG_$ELABOCHOICE_PKG_$ELAB QITERATION_PKG_$ELABQITERATION_PKG_$ELAB XVARIANT_ALTERNATIVE_CLASS_PKG_$XVARIANT_ALTERNATIVE_CLASS_PKG_$ \LIBRARY_IDENTIFICATION_MANAGER$\LIBRARY_IDENTIFICATION_MANAGER$ 2PROGRAMLIBRARY_$ELAB2PROGRAMLIBRARY_$ELAB 3PROGRAMLIBRARY$ELAB3PROGRAMLIBRARY$ELAB LIBRARY_DEPENDENCY_MANAGER$ELABLIBRARY_DEPENDENCY_MANAGER$ELAB `COMP_UNIT_CLASS_PKG$ELAB`COMP_UNIT_CLASS_PKG$ELAB )GENERIC_HEADER_CLASS_PKG$ELAB)GENERIC_HEADER_CLASS_PKG$ELAB 3OBJECT_DEF_PKG$ELAB3OBJECT_DEF_PKG$ELAB /HEADER_PKG$ELAB/HEADER_PKG$ELAB ;GENERAL_ASSOC_PKG$ELAB;GENERAL_ASSOC_PKG$ELAB 9SUBP_DEF_PKG$ELAB9SUBP_DEF_PKG$ELAB -PKG_DEF_PKG$ELAB-PKG_DEF_PKG$ELAB 1OBJECT_TYPE_PKG$ELAB1OBJECT_TYPE_PKG$ELAB ITEM_PKG$ELABITEM_PKG$ELAB 7CONSTRAINT_PKG$ELAB7CONSTRAINT_PKG$ELAB 5NAME_EXP_PKG$ELAB5NAME_EXP_PKG$ELAB =BLOCK_STUB_PKG$ELAB=BLOCK_STUB_PKG$ELAB ?TYPE_SPEC_PKG$ELAB?TYPE_SPEC_PKG$ELAB HALTERNATIVE_PKG$ELABHALTERNATIVE_PKG$ELAB DAGG_COMPONENT_PKG$ELABDAGG_COMPONENT_PKG$ELAB PCHOICE_PKG$ELABPCHOICE_PKG$ELAB FSTM_PKG$ELABFSTM_PKG$ELAB RITERATION_PKG$ELABRITERATION_PKG$ELAB MINNER_RECORD_CLASS_PKG$ELABMINNER_RECORD_CLASS_PKG$ELAB YVARIANT_ALTERNATIVE_CLASS_PKG$EYVARIANT_ALTERNATIVE_CLASS_PKG$E HALSTEAD$ELABHALSTEAD$ELABADA$INIT_COMPONENTLIB$INITIALIZEi$CODE|LIB$INITIALIZE} HALSTEADHALSTEADoTRANSFER$ADDRESSw?=:::::::::::::: halstead.src :::::::::::::: :::::::::::::: block_u.bdy :::::::::::::: --VMS file: %nosc.work.tools.halstead.source*(block_u.bdy) --UTS file: /nosccomp/byron/_vms//nosc/work/tools/halstead/COMP/block_u.bdy -- $Source: /nosc/work/tools/halstead/RCS/block_u.bdy,v $ -- $Revision: 1.2 $ -- $Date: 86/02/04 22:05:46 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.2 $"); with ML_Source_Position_Pkg; package body Block_Utilities is package MLSP renames ML_Source_Position_Pkg; -------------------------------------------------------------------------- -- LOCAL SUBPROGRAMS -------------------------------------------------------------------------- function Is_Source_Position_Null ( Position :in MLSP.Source_Position ) return boolean; --| OVERVIEW --| This procedure returns true if the source position passed in --| is null. This means that column and line of the --| Position.first_location is 0. -------------------------------------------------------------------------- function In_Declare_Block ( --| This function determines whether --| we are in a block with declarations. --| If we are it returns true otherwise --| false. block :in BLOCK_STUB.Locator ) return boolean is use SeqOfITEM; I :Generator; begin --| OVERVIEW --| This function is used to determined if in fact the block --| passed in is a block with explicit declarations which --| means the token declare appears in the source program. --| This is determined by walking down the list of declarations --| until something which is not an implicit label is encountered. --| Implicit labels are inserted in the as_item_s list --| of the enclosing block. Thus if the only elements of the --| as_item_s of the block are implicit_labels then the token --| declare does not appear in the source program. StartForward (as_item_s (block), I); while not Finished(I) loop case Kind (Cell (I)) is when implicit_label_declKind => Forward (I); when others => EndIterate (I); return true; end case; end loop; EndIterate (I); return false; end In_declare_block; -------------------------------------------------------------------------- function Is_Block_Labeled ( --| This function returns true --| if the block passed in has a label --| and returns false otherwise. block :in block_stmNode.Locator ) return boolean is begin return not Is_Source_Position_Null ( lx_srcpos (as_block_label (block)) ); end; -------------------------------------------------------------------------- function Is_Source_Position_Null ( Position :in MLSP.Source_Position ) return boolean is begin return MLSP."=" (Position.first_location,0); end; end Block_Utilities; :::::::::::::: block_u.spc :::::::::::::: --VMS file: %nosc.work.tools.halstead.source*(block_u.spc) --UTS file: /nosccomp/byron/_vms//nosc/work/tools/halstead/COMP/block_u.spc -- $Source: /nosc/work/tools/halstead/RCS/block_u.spc,v $ -- $Revision: 1.2 $ -- $Date: 86/02/04 22:05:09 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.2 $"); with ST_DIANA; use ST_DIANA; package Block_Utilities is -------------------------------------------------------------------------- function In_Declare_Block ( --| This function determines whether --| we are in a block with declarations. --| If we are it returns true otherwise --| false. block :in BLOCK_STUB.Locator ) return boolean; function Is_Block_Labeled ( --| This function returns true --| if the block passed in has a label --| and returns false otherwise. block :in block_stmNode.Locator ) return boolean; end Block_Utilities; :::::::::::::: comlin.bdy :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/comlin.bdy,v $ -- $Revision: 1.18 $ -- $Date: 85/03/25 21:03:22 $ -- $Author: buddy $ with Text_IO; use Text_IO; with Int_IO; use Int_IO; package body CommandLine is TokenSeparator :constant character := '%'; -------------------------------------------------------------------------- procedure ScanForChar ( S :in String; C :in character; Start :in positive; Place : out natural ) is Temp :positive := Start; Found :boolean := false; begin Place := 0; while (Temp <= S'Last) and (not Found) loop if S(Temp) = C then Place := Temp; Found := true; end if; Temp := Temp + 1; end loop; end; -------------------------------------------------------------------------- function GetNumberOfUnits( S :in String ) return natural is count :natural := 0; begin for i in S'Range loop if S(i) = TokenSeparator then count := count + 1; end if; end loop; return count; end; -------------------------------------------------------------------------- function GetToken ( S :in String; Start :in positive ) return String is EndOfToken :natural; begin ScanForChar (S, TokenSeparator, Start, EndOfToken); if EndOfToken = 0 then raise TokenNotFound; else return S(Start..EndOfToken - 1); end if; end; -------------------------------------------------------------------------- procedure Advance ( S :in String; Start :in out positive ) is begin Start := Start + GetToken (S, Start)'Length + 1; end; -------------------------------------------------------------------------- function GetSpec ( S :in String; Start :in positive ) return boolean is begin if boolean'Value (GetToken (S, Start)) in false..true then return boolean'Value (GetToken (S, Start)); end if; exception when CONSTRAINT_ERROR => raise ExpectingBoolean; end; -------------------------------------------------------------------------- function IsSubUnit ( S :in String; Start :in positive ) return boolean is PeriodPosition :natural; begin ScanForChar (S, '.', Start, PeriodPosition); if (S'First < PeriodPosition) and (PeriodPosition < S'Last) then return true; else return false; end if; end; -------------------------------------------------------------------------- function GetParent ( S :in String; Start :in positive ) return String is PeriodPosition :natural; begin ScanForChar (S, '.', Start, PeriodPosition); if PeriodPosition = 0 then raise InvalidSubUnit; else Return S(Start..PeriodPosition - 1); end if; end; -------------------------------------------------------------------------- function GetSubUnit ( S :in String; Start :in positive ) return String is PeriodPosition :natural; EndToken :natural; begin ScanForChar (S, '.', Start, PeriodPosition); ScanForChar (S, TokenSeparator, PeriodPosition, EndToken); if EndToken = 0 then raise InvalidSubUnit; else return S(PeriodPosition + 1..EndToken - 1); end if; end; -------------------------------------------------------------------------- end CommandLine; :::::::::::::: comlin.spc :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/comlin.spc,v $ -- $Revision: 1.5 $ -- $Date: 85/03/24 16:17:23 $ -- $Author: buddy $ package CommandLine is TokenNotFound :exception; ExpectingBoolean :exception; InvalidSubUnit :exception; function GetNumberOfUnits( S :in String ) return natural; -------------------------------------------------------------------------- procedure Advance ( S :in String; Start :in out positive ); -------------------------------------------------------------------------- function GetToken ( S :in String; Start :in positive ) return String; -------------------------------------------------------------------------- function IsSubUnit ( S :in String; Start :in positive ) return boolean; -------------------------------------------------------------------------- function GetParent ( S :in String; Start :in positive ) return String; -------------------------------------------------------------------------- function GetSpec ( S :in String; Start :in positive ) return boolean; -------------------------------------------------------------------------- function GetSubUnit ( S :in String; Start :in positive ) return String; -------------------------------------------------------------------------- end CommandLine; :::::::::::::: count.bdy :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/count5.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/12/31 14:51:21 $ -- $Author: maria $ --pragma revision ("$Revision: 1.1 $"); -- $Source: /nosc/work/tools/halstead/RCS/count5.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/12/31 14:51:21 $ -- $Author: maria $ --pragma revision ("$Revision: 1.1 $"); -- $Source: /nosc/work/tools/halstead/RCS/count5.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/12/31 14:51:21 $ -- $Author: maria $ --pragma revision ("$Revision: 1.1 $"); -- $Source: /nosc/work/tools/halstead/RCS/count5.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/12/31 14:51:21 $ -- $Author: maria $ --pragma revision ("$Revision: 1.1 $"); with Text_IO; use Text_IO; with Int_IO; use Int_IO; package body count is TokenClassification: array (D.TokenItem) of D.Class := ( D.abortz => D.operator, D.acceptz => D.operator, D.accessz => D.operator, D.allz => D.operator, D.and_thenz => D.operator, D.arrayz => D.operator, D.atz => D.neither, D.beginz => D.neither, D.bodyz => D.neither, D.body_packagez => D.neither, D.body_taskz => D.neither, D.casez => D.neither, D.case_stmz => D.neither, D.case_variantz => D.neither, D.constantz => D.operator, D.declarez => D.operator, D.delayz => D.operator, D.deltaz => D.operator, D.digitsz => D.operator, D.doz => D.neither, D.elsez => D.operator, D.else_ifz => D.operator, D.else_orz => D.operator, D.else_selectz => D.operator, D.elsifz => D.operator, D.endz => D.neither, D.end_acceptz => D.neither, D.end_beginz => D.neither, D.end_case_stmz => D.operator, D.end_case_variantz => D.operator, D.end_ifz => D.operator, D.end_loopz => D.operator, D.end_package_bdyz => D.operator, D.end_package_spcz => D.operator, D.end_recordz => D.operator, D.end_record_repz => D.operator, D.end_selectz => D.operator, D.end_task_spcz => D.operator, D.entryz => D.operator, D.exceptionz => D.operator, D.exitz => D.operator, D.forz => D.neither, D.for_loopz => D.neither, D.for_repz => D.neither, D.functionz => D.operator, D.genericz => D.operator, D.gotoz => D.operator, D.ifz => D.neither, D.inz => D.operator, D.in_loopz => D.operator, D.in_membershipz => D.operator, D.in_out_parameterz => D.neither, D.in_parameterz => D.neither, D.isz => D.neither, D.is_case_stmz => D.neither, D.is_case_variantz => D.neither, D.is_functionz => D.neither, D.is_genericz => D.neither, D.is_package_bdyz => D.neither, D.is_package_spcz => D.neither, D.is_procedurez => D.neither, D.is_separatez => D.operator, D.is_subtypez => D.neither, D.is_typez => D.neither, D.is_task_bdyz => D.neither, D.is_task_spcz => D.neither, D.limitedz => D.operator, D.loopz => D.neither, D.modz => D.operator, D.newz => D.neither, D.new_allocatorz => D.operator, D.new_derived_typez => D.operator, D.new_generic_instz => D.operator, D.not_in_membershipz => D.operator, D.nullz => D.neither, D.null_valuez => D.operand, D.null_stmz => D.operator, D.null_fieldz => D.operator, D.ofz => D.operator, D.orz => D.operator, D.or_elsez => D.operator, D.or_selectz => D.operator, D.othersz => D.neither, D.others_aggregatez => D.operator, D.others_casez => D.operator, D.others_exceptionz => D.operator, D.others_variantz => D.operator, D.outz => D.neither, D.packagez => D.neither, D.package_bdyz => D.neither, D.package_spcz => D.neither, D.pragmaz => D.operator, D.privatez => D.neither, D.private_sectionz => D.operator, D.private_typez => D.operator, D.procedurez => D.neither, D.raisez => D.operator, D.rangez => D.operator, D.recordz => D.neither, D.record_typez => D.neither, D.record_repz => D.neither, D.renamesz => D.operator, D.returnz => D.operator, D.reversez => D.operator, D.selectz => D.neither, D.separatez => D.neither, D.subtypez => D.operator, D.taskz => D.neither, D.task_bdyz => D.neither, D.task_spcz => D.neither, D.terminatez => D.operator, D.thenz => D.neither, D.then_andz => D.operator, D.typez => D.operator, D.usez => D.neither, D.use_contextz => D.operator, D.use_repz => D.operator, D.whenz => D.neither, D.when_case_stmz => D.neither, D.when_exitz => D.neither, D.when_exceptionz => D.neither, D.when_selectz => D.neither, D.when_case_variantz => D.neither, D.whilez => D.operator, D.withz => D.neither, D.with_contextz => D.operator, D.with_genericz => D.operator, ------------- punctuation -------------- D.arrowz => D.operator, D.barz => D.operator, D.boxz => D.neither, D.box_rangez => D.operator, D.box_default_subpz => D.operator, D.character_literalz => D.operand, D.closed_anglesz => D.neither, D.closed_parenthesisz => D.neither, D.colon_equalsz => D.operator, D.colonz => D.operator, D.commaz => D.operator, D.dotz => D.operator, D.dot_dot_rangez => D.operator, D.double_quotez => D.operand, D.numeric_literalz => D.operand, D.open_anglesz => D.operator, D.open_parenthesisz => D.operator, D.semicolonz => D.neither, D.single_quotez => D.neither, D.tickz => D.operator, D.declare_blockz => D.neither ); --| This is a map from token types to symbol classification. --| It indicates which class (D.operator, operand, neither) --| a token is in. -------------------------------------------------------------------------- function RemoveLastChar ( --| This removes the last character from --| the string S. This is used to get --| rid of the z's in the TokenItems. S :in String ) return String is begin return S(S'first..S'last - 1); end; -------------------------------------------------------------------------- procedure HalsteadCount ( TokenInfo :in D.TokenCountType; VerboseOn :in boolean; Nn: in out CT.NnInfoType ) is begin for t in D.TokenItem loop if TokenInfo(t) > 0 then Nn(TokenClassification(t)).Vocabulary := Nn(TokenClassification(t)).Vocabulary + 1; Nn(TokenClassification(t)).Usage := Nn(TokenClassification(t)).Usage + TokenInfo(t); if VerboseOn then Put (Standard_Output, "number of "); Put (Standard_Output, RemoveLastChar (D.TokenItem ' image (t))); Put (Standard_Output, " tokens is "); Put (Standard_Output, TokenInfo(t)); New_Line (Standard_Output); end if; end if; end loop; end HalsteadCount; end count; :::::::::::::: count.spc :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/count.spc,v $ -- $Revision: 1.3 $ -- $Date: 85/06/13 13:29:12 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.3 $"); with Definitions; with Count_Types; package Count is package D renames Definitions; package CT renames Count_Types; -------------------------------------------------------------------------- procedure HalsteadCount ( --| This procedure determines which tokens --| are operators and operands and counts --| them. TokenInfo :in D.TokenCountType; VerboseOn :in boolean; Nn: in out CT.NnInfoType ); -------------------------------------------------------------------------- end Count; :::::::::::::: countype.bdy :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/countype.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/07/04 11:38:21 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.1 $"); -- $Source: /nosc/work/tools/halstead/RCS/countype.bdy,v $ -- $Revision: 1.1 $ -- $Date: 85/07/04 11:38:21 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.1 $"); with Definitions; package body Count_Types is -------------------------------------------------------------------------- function AddCounts ( --| This function Adds two records and --| returns their sum. L :in NnInfoType; R :in NnInfoType ) return NnInfoType is Sum :NnInfoType; begin for c in Definitions.Class loop Sum(c).Vocabulary := L(c).Vocabulary + R(c).Vocabulary; Sum(c).Usage := L(c).Usage + R(c).Usage; end loop; return Sum; end; -------------------------------------------------------------------------- procedure ZeroCount (--| Sets the counts of all the classes of NnInfo --| to 0. NnInfo :in out NnInfoType ) is begin for c in Definitions.Class loop NnInfo(c).Vocabulary := 0; NnInfo(c).Usage := 0; end loop; end; ------------------------------------------------------------------------- - end Count_Types; :::::::::::::: countype.spc :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/countype.spc,v $ -- $Revision: 1.1 $ -- $Date: 85/07/04 11:36:37 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.1 $"); -- $Source: /nosc/work/tools/halstead/RCS/countype.spc,v $ -- $Revision: 1.1 $ -- $Date: 85/07/04 11:36:37 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.1 $"); with Definitions; package Count_Types is --| OVERVIEW --| This package defines types that are being used in the counting --| of tokens. It also provides an operation AddCounts which --| a function which returns the sum of two NnInfoType records. --| This is needed because it is necessary to separate the token --| counts which result from DEF_ID_Analysis and Literal_Analysis --| and the token counts which result from keyword other syntactic --| constructs. type NnRecordType is record Vocabulary: natural := 0; Usage: natural := 0; end record; --| This package is used to define the NnInfoType used by all --| the different counting strategies. type NnInfoType is array (Definitions.Class) of NnRecordType; --| NnInfoType keeps track of the vocabulary and usage for each --| class (i.e. operator, operand, and neither). --| --| Vocabulary keeps track of the number of unique symbols in --| the source program. For example: --| --| Nn :NnInfoType; --| --| Then Nn(operator).Vocabulary corresponds to n1 the unique --| number of operators in Halstead's notation and --| Nn(operand).Vocabulary corresponds to n2 the unique number of --| operands. Thus --| --| Nn(operator).Vocabulary + Nn(operand).Vocabulary =n --| --| which is the vocabulary for the source program. --| --| Usage keeps track of the total usage of each class of --| operator, operand, and neither. Nn(operator).Usage --| Nn(operand).Usage correspond to N1 and N2 in Halstead --| notation and their sum corresponds to N which is the length of -------------------------------------------------------------------------- function AddCounts ( --| This function Adds two records and --| returns their sum. L :in NnInfoType; R :in NnInfoType ) return NnInfoType ; -------------------------------------------------------------------------- procedure ZeroCount (--| Sets the counts of NnInfo to 0. NnInfo :in out NnInfoType ); ------------------------------------------------------------------------- - end Count_Types; :::::::::::::: defs.bdy :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/defs.bdy,v $ -- $Revision: 5.1 $ -- $Date: 85/04/04 08:30:38 $ -- $Author: buddy $ with VmmTextPkg; with unchecked_deallocation; package body Definitions is function "<" ( --| This function compares the text of two literals --| to see if X is lexigraphically less than Y. X :in Source_Text.Locator; Y :in Source_Text.Locator ) return boolean is begin return VmmTextPkg.Value (Source_Text.Value (X)) < VmmTextPkg.Value (Source_Text.Value (Y)); end; package body Literal_Set is ------------------------------------------------------------------------------ -- Nested Private Definitions ------------------------------------------------------------------------------- package body TreePkg is --------------------------------------------------------------------------- -- Nested Private Definitions --------------------------------------------------------------------------- package body NodeOrder is procedure Free is new unchecked_deallocation (Cell, List); -------------------------------------------------------------------------- function Last (L: in List) return List is Place_In_L: List; Temp_Place_In_L: List; --| Link down the list L and return the pointer to the last element --| of L. If L is null raise the EmptyList exception. begin if L = null then raise EmptyList; else --| Link down L saving the pointer to the previous element in --| Temp_Place_In_L. After the last iteration Temp_Place_In_L --| points to the last element in the list. Place_In_L := L; while Place_In_L /= null loop Temp_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end loop; return Temp_Place_In_L; end if; end Last; -------------------------------------------------------------------------- procedure Attach (List1: in out List; List2: in List ) is EndOfList1: List; --| Attach List2 to List1. --| If List1 is null return List2 --| If List1 equals List2 then raise CircularList --| Otherwise get the pointer to the last element of List1 and change --| its Next field to be List2. begin if List1 = null then List1 := List2; return; elsif List1 = List2 then raise CircularList; else EndOfList1 := Last (List1); EndOfList1.Next := List2; end if; end Attach; -------------------------------------------------------------------------- procedure Attach (L: in out List; Element: in Tree ) is NewEnd: List; --| Create a list containing Element and attach it to the end of L begin NewEnd := new Cell'(Info => Element, Next => null); Attach (L, NewEnd); end; -------------------------------------------------------------------------- function Attach (Element1: in Tree; Element2: in Tree ) return List is NewList: List; --| Create a new list containing the information in Element1 and --| attach Element2 to that list. begin NewList := new Cell'(Info => Element1, Next => null); Attach (NewList, Element2); return NewList; end; -------------------------------------------------------------------------- procedure Attach (Element: in Tree; L: in out List ) is --| Create a new cell whose information is Element and whose Next --| field is the list L. This prepends Element to the List L. begin L := new Cell'(Info => Element, Next => L); end; -------------------------------------------------------------------------- function Attach ( List1: in List; List2: in List ) return List is Last_Of_List1: List; begin if List1 = null then return List2; elsif List1 = List2 then raise CircularList; else Last_Of_List1 := Last (List1); Last_Of_List1.Next := List2; return List1; end if; end Attach; ------------------------------------------------------------------------- function Attach( L: in List; Element: in Tree ) return List is NewEnd: List; Last_Of_L: List; --| Create a list called NewEnd and attach it to the end of L. --| If L is null return NewEnd --| Otherwise get the last element in L and make its Next field --| NewEnd. begin NewEnd := new Cell'(Info => Element, Next => null); if L = null then return NewEnd; else Last_Of_L := Last (L); Last_Of_L.Next := NewEnd; return L; end if; end Attach; -------------------------------------------------------------------------- function Attach (Element: in Tree; L: in List ) return List is begin return (new Cell'(Info => Element, Next => L)); end Attach; -------------------------------------------------------------------------- function Copy (L: in List) return List is --| If L is null return null --| Otherwise recursively copy the list by first copying the information --| at the head of the list and then making the Next field point to --| a copy of the tail of the list. begin if L = null then return null; else return new Cell'(Info => L.Info, Next => Copy (L.Next)); end if; end Copy; -------------------------------------------------------------------------- function Create return List is --| Return the empty list. begin return null; end Create; -------------------------------------------------------------------------- procedure DeleteHead (L: in out List) is TempList: List; --| Remove the element of the head of the list and return it to the heap. --| If L is null EmptyList. --| Otherwise save the Next field of the first element, remove the first --| element and then assign to L the Next field of the first element. begin if L = null then raise EmptyList; else TempList := L.Next; Free (L); L := TempList; end if; end DeleteHead; -------------------------------------------------------------------------- procedure DeleteItem (L: in out List; Element: in Tree ) is Temp_L :List; --| Remove the first element in the list with the value Element. --| If the first element of the list is equal to element then --| remove it. Otherwise, recurse on the tail of the list. begin if L.Info = Element then DeleteHead(L); else DeleteItem(L.Next, Element); end if; exception when constraint_error => raise ItemNotPresent; end DeleteItem; -------------------------------------------------------------------------- procedure DeleteItems (L: in out List; Element: in Tree ) is Place_In_L :List; --| Current place in L. Last_Place_In_L :List; --| Last place in L. Temp_Place_In_L :List; --| Holds a place in L to be removed. Found :boolean := false; --| Indicates if an element with --| the correct value was found. --| Walk over the list removing all elements with the value Element. begin Place_In_L := L; Last_Place_In_L := null; while (Place_In_L /= null) loop --| Found an element equal to Element if Place_In_L.Info = Element then Found := true; --| If Last_Place_In_L is null then we are at first element --| in L. if Last_Place_In_L = null then Temp_Place_In_L := Place_In_L; L := Place_In_L.Next; else Temp_Place_In_L := Place_In_L; --| Relink the list Last's Next gets Place's Next Last_Place_In_L.Next := Place_In_L.Next; end if; --| Move Place_In_L to the next position in the list. --| Free the element. --| Do not update the last element in the list it remains the --| same. Place_In_L := Place_In_L.Next; Free (Temp_Place_In_L); else --| Update the last place in L and the place in L. Last_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end if; end loop; --| If we have not found an element raise an exception. if not Found then raise ItemNotPresent; end if; end DeleteItems; -------------------------------------------------------------------------- procedure Destroy (L: in out List) is Place_In_L: List; HoldPlace: List; --| Walk down the list removing all the elements and set the list to --| the empty list. begin Place_In_L := L; while Place_In_L /= null loop HoldPlace := Place_In_L; Place_In_L := Place_In_L.Next; Free (HoldPlace); end loop; L := null; end Destroy; -------------------------------------------------------------------------- function FirstValue (L: in List) return Tree is --| Return the first value in the list. begin if L = null then raise EmptyList; else return (L.Info); end if; end FirstValue; -------------------------------------------------------------------------- procedure Forword (I: in out ListIter) is --| Return the pointer to the next member of the list. Temp_L :List; begin Temp_L := List (I); I := ListIter (Temp_L.Next); end Forword; -------------------------------------------------------------------------- function IsInList (L: in List; Element: in Tree ) return boolean is Place_In_L: List; --| Check if Element is in L. If it is return true otherwise return false. begin Place_In_L := L; while Place_In_L /= null loop if Place_In_L.Info = Element then return true; end if; Place_In_L := Place_In_L.Next; end loop; return false; end IsInList; -------------------------------------------------------------------------- function IsEmpty (L: in List) return boolean is --| Is the list L empty. begin return (L = null); end IsEmpty; -------------------------------------------------------------------------- function LastValue (L: in List) return Tree is LastElement: List; --| Return the value of the last element of the list. Get the pointer --| to the last element of L and then return its information. begin LastElement := Last (L); return LastElement.Info; end LastValue; -------------------------------------------------------------------------- function Length (L: in List) return integer is --| Recursively compute the length of L. The length of a list is --| 0 if it is null or 1 + the length of the tail. begin if L = null then return (0); else return (1 + Length (Tail (L))); end if; end Length; -------------------------------------------------------------------------- function MakeListIter (L: in List) return ListIter is --| Start an iteration operation on the list L. Do a type conversion --| from List to ListIter. begin return ListIter (L); end MakeListIter; -------------------------------------------------------------------------- function More (L: in ListIter) return boolean is --| This is a test to see whether an iteration is complete. begin return L /= null; end; -------------------------------------------------------------------------- procedure Next (Place: in out ListIter; Info: out Tree ) is PlaceInList: List; --| This procedure gets the information at the current place in the List --| and moves the ListIter to the next postion in the list. --| If we are at the end of a list then exception NoMore is raised. begin if Place = null then raise NoMore; else PlaceInList := List(Place); Info := PlaceInList.Info; Place := ListIter(PlaceInList.Next); end if; end Next; -------------------------------------------------------------------------- procedure ReplaceHead (L: in out List; Info: in Tree ) is --| This procedure replaces the information at the head of a list --| with the given information. If the list is empty the exception --| EmptyList is raised. begin if L = null then raise EmptyList; else L.Info := Info; end if; end ReplaceHead; -------------------------------------------------------------------------- procedure ReplaceTail (L: in out List; NewTail: in List ) is Temp_L: List; --| This destroys the tail of a list and replaces the tail with --| NewTail. If L is empty EmptyList is raised. begin Destroy(L.Next); L.Next := NewTail; exception when constraint_error => raise EmptyList; end ReplaceTail; -------------------------------------------------------------------------- function Tail (L: in List) return List is --| This returns the list which is the tail of L. If L is null Empty --| List is raised. begin if L = null then raise EmptyList; else return L.Next; end if; end Tail; -------------------------------------------------------------------------- function Equal (List1: in List; List2: in List ) return boolean is PlaceInList1: List; PlaceInList2: List; Contents1: Tree; Contents2: Tree; --| This function tests to see if two lists are equal. Two lists --| are equal if for all the elements of List1 the corresponding --| element of List2 has the same value. Thus if the 1st elements --| are equal and the second elements are equal and so up to n. --| Thus a necessary condition for two lists to be equal is that --| they have the same number of elements. --| This function walks over the two list and checks that the --| corresponding elements are equal. As soon as we reach --| the end of a list (PlaceInList = null) we fall out of the loop. --| If both PlaceInList1 and PlaceInList2 are null after exiting the loop --| then the lists are equal. If they both are not null the lists aren't --| equal. Note that equality on elements is based on a user supplied --| function Equal which is used to test for item equality. begin PlaceInList1 := List1; PlaceInList2 := List2; while (PlaceInList1 /= null) and (PlaceInList2 /= null) loop if PlaceInList1.Info /= PlaceInList2.Info then return false; end if; PlaceInList1 := PlaceInList1.Next; PlaceInList2 := PlaceInList2.Next; end loop; return ((PlaceInList1 = null) and (PlaceInList2 = null) ); end Equal; end NodeOrder; -------------------------------------------------------------------------- ---------------------------------------------------------------------------- -- Local Subprograms ---------------------------------------------------------------------------- procedure Free is new unchecked_deallocation (Node, Tree); function equal (X, Y: in Member) return boolean is begin return (not (X < Y)) and (not (Y < X)); end; ------------------------------------------------------------------------------ function Generate (T :in Tree ) return Nodeorder.List is L : Nodeorder.List; --| This routine generates a list of pointers to nodes in the tree t. --| The list is ordered with respect to the order of the nodes in the tree. --| generate does a depth first search of the tree. --| 1. It first visits the leftchild of t and generates the list for that. --| 2. It then appends the root node of t to the list generated for the left --| child. --| 3. It then appends the list generated for the rightchild to the list --| generated for the leftchild and the root. --| begin L := NodeOrder.Create; if T /= null then L := Generate (T.Leftchild); Nodeorder.Attach (L, T); Nodeorder.Attach (L, Generate (T.Rightchild)); end if; return L; End Generate; ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Visible Subprograms ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ function Create return Tree is begin return null; end; ----------------------------------------------------------------------------- procedure Deposit ( I :in Member; S :in Tree ) is begin S.Info := I; end; ------------------------------------------------------------------------------ procedure DestroyTree ( T :in out Tree) is --| This procedure recursively destroys the tree T. --| 1. It destroy the leftchild of T --| 2. It then destroys the rightchild of T. --| 3. It then destroy the root T and set T to be null. begin if T /= null then DestroyTree (T.leftchild); DestroyTree (T.rightchild); Free (T); end if; end DestroyTree; ------------------------------------------------------------------------------ procedure InsertNode ( N :in out Member; --| Node being inserted. T :in out Tree; --| Tree node is being inserted --| into. Root : out Tree; --| Root of the subtree which node N --| heads. This is the position of --| node N in T; Exists : out boolean --| If this node already exists in --| the tree then Exists is true. If --| If this is the first insertion --| Exists is false. ) is --| This inserts the node N in T. --| 1. If T is null then a new node is allocated and assigned to T --| 2. If T is not null then T is searched for the proper place to insert n. --| This is first done by checking whether N < rightchild --| 3. If this is not true then we check to see if leftchild < N --| 4. If this is not true then N is in the tree. begin if T = null then T := new Node ' (Info => N, leftchild => null, rightchild => null); Root := T; Exists := false; N := T.Info; elsif N < T.Info then InsertNode (N, T.leftchild, Root, Exists); elsif T.Info < N then InsertNode (N, T.rightchild, Root, Exists); else Root := T; Exists := true; N := T.Info; end if; end InsertNode; ------------------------------------------------------------------------------ function MakeTreeIter (T :in Tree ) return TreeIter is I :TreeIter; --| This sets up the iterator for a tree T. --| The NodeList keeps track of the order of the nodes of T. The NodeList --| is computed by first invoking Generate of the leftchild then append --| the root node to NodeList and then append the result of Generate --| to NodeList. Since the tree is ordered such that --| --| leftchild < root root < rightchild --| --| NodeOrder returns the nodes in ascending order. --| --| Thus NodeList keeps the list alive for the duration of the iteration --| operation. The variable State is the a pointer into the NodeList --| which is the current place of the iteration. begin I.NodeList := NodeOrder.Create; if T /= null then I.NodeList := Generate (T.leftchild); NodeOrder.Attach (I.NodeList, T); NodeOrder.Attach (I.NodeList, Generate (T.rightChild)); end if; I.State := NodeOrder.MakeListIter (I.NodeList); return I; end; ------------------------------------------------------------------------------ function More (I :in TreeIter) return boolean is begin return NodeOrder.More (I.State); end; ------------------------------------------------------------------------------ procedure Next ( I :in out TreeIter; Info : out Member ) is T: Tree; --| Next returns the information at the current position in the iterator --| and increments the iterator. This is accomplished by using the iterater --| associated with the NodeOrder list. This returns a pointer into the Tree --| and then the information found at this node in T is returned. begin NodeOrder.Next (I.State, T); Info := T.Info; end; ------------------------------------------------------------------------------- end TreePkg; ------------------------------------------------------------------------------- -- Local Subprograms ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- function "<" ( --| Implements "<" for the type member. X :in Member; Y :in Member ) return boolean is begin return X.Info < Y.Info; end; ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- Visible Subprograms ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- function Cardinality ( S :in Set --| The set whose size is being computed. ) return natural is T :TreePkg.TreeIter; M :Member; count :natural := 0; begin T := TreePkg.MakeTreeIter (S.SetRep); while TreePkg.More (T) loop TreePkg.Next (T, M); count := count + 1; end loop; return count; end Cardinality; ------------------------------------------------------------------------------- function Create return Set is S :Set; begin S.SetRep := TreePkg.Create; return S; end Create; ------------------------------------------------------------------------------ procedure Destroy ( S :in out Set ) is begin TreePkg.DestroyTree (S.SetRep); end Destroy; ----------------------------------------------------------------------------- function GetCount ( I :in SetIter ) return natural is begin return I.Count; end; ----------------------------------------------------------------------------- procedure Insert( M :in Source_Text.Locator; S :in out Set ) is Subtree :TreePkg.Tree; Exists :boolean; MemberToEnter :Member := ( Info => M, count => 1); begin --| If NewMember doesn't exist in SetRep it is added. If it does exist --| Exists comes back true and then M's count is updated. Since the --| first argument of TreePkg.Insert is in out, after Insert --| MemberToEnter has the value stored in the tree. Thus if we --| need to update the count we can simple bump the count in MemberToEnter. TreePkg.InsertNode (MemberToEnter, S.SetRep, SubTree, Exists); if Exists then MemberToEnter.Count := MemberToEnter.Count + 1; TreePkg.Deposit (MemberToEnter, SubTree); end if; end Insert; ------------------------------------------------------------------------------ function MakeSetIter ( S :in Set ) return SetIter is I :SetIter; begin I.Place := TreePkg.MakeTreeIter (S.SetRep); I.Count := 0; return I; end; ------------------------------------------------------------------------------ function More ( I :in SetIter ) return boolean is begin return TreePkg.More (I.Place); end; ------------------------------------------------------------------------------ procedure Next ( I :in out SetIter; M : out Source_Text.Locator ) is TempMember :Member; begin TreePkg.Next (I.Place, TempMember); M := TempMember.Info; I.Count := TempMember.Count; end; ------------------------------------------------------------------------------ end Literal_Set; package body DEF_ID_Set is ------------------------------------------------------------------------------ -- Nested Private Definitions ------------------------------------------------------------------------------- package body TreePkg is --------------------------------------------------------------------------- -- Nested Private Definitions --------------------------------------------------------------------------- package body NodeOrder is procedure Free is new unchecked_deallocation (Cell, List); -------------------------------------------------------------------------- function Last (L: in List) return List is Place_In_L: List; Temp_Place_In_L: List; --| Link down the list L and return the pointer to the last element --| of L. If L is null raise the EmptyList exception. begin if L = null then raise EmptyList; else --| Link down L saving the pointer to the previous element in --| Temp_Place_In_L. After the last iteration Temp_Place_In_L --| points to the last element in the list. Place_In_L := L; while Place_In_L /= null loop Temp_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end loop; return Temp_Place_In_L; end if; end Last; -------------------------------------------------------------------------- procedure Attach (List1: in out List; List2: in List ) is EndOfList1: List; --| Attach List2 to List1. --| If List1 is null return List2 --| If List1 equals List2 then raise CircularList --| Otherwise get the pointer to the last element of List1 and change --| its Next field to be List2. begin if List1 = null then List1 := List2; return; elsif List1 = List2 then raise CircularList; else EndOfList1 := Last (List1); EndOfList1.Next := List2; end if; end Attach; -------------------------------------------------------------------------- procedure Attach (L: in out List; Element: in Tree ) is NewEnd: List; --| Create a list containing Element and attach it to the end of L begin NewEnd := new Cell'(Info => Element, Next => null); Attach (L, NewEnd); end; -------------------------------------------------------------------------- function Attach (Element1: in Tree; Element2: in Tree ) return List is NewList: List; --| Create a new list containing the information in Element1 and --| attach Element2 to that list. begin NewList := new Cell'(Info => Element1, Next => null); Attach (NewList, Element2); return NewList; end; -------------------------------------------------------------------------- procedure Attach (Element: in Tree; L: in out List ) is --| Create a new cell whose information is Element and whose Next --| field is the list L. This prepends Element to the List L. begin L := new Cell'(Info => Element, Next => L); end; -------------------------------------------------------------------------- function Attach ( List1: in List; List2: in List ) return List is Last_Of_List1: List; begin if List1 = null then return List2; elsif List1 = List2 then raise CircularList; else Last_Of_List1 := Last (List1); Last_Of_List1.Next := List2; return List1; end if; end Attach; ------------------------------------------------------------------------- function Attach( L: in List; Element: in Tree ) return List is NewEnd: List; Last_Of_L: List; --| Create a list called NewEnd and attach it to the end of L. --| If L is null return NewEnd --| Otherwise get the last element in L and make its Next field --| NewEnd. begin NewEnd := new Cell'(Info => Element, Next => null); if L = null then return NewEnd; else Last_Of_L := Last (L); Last_Of_L.Next := NewEnd; return L; end if; end Attach; -------------------------------------------------------------------------- function Attach (Element: in Tree; L: in List ) return List is begin return (new Cell'(Info => Element, Next => L)); end Attach; -------------------------------------------------------------------------- function Copy (L: in List) return List is --| If L is null return null --| Otherwise recursively copy the list by first copying the information --| at the head of the list and then making the Next field point to --| a copy of the tail of the list. begin if L = null then return null; else return new Cell'(Info => L.Info, Next => Copy (L.Next)); end if; end Copy; -------------------------------------------------------------------------- function Create return List is --| Return the empty list. begin return null; end Create; -------------------------------------------------------------------------- procedure DeleteHead (L: in out List) is TempList: List; --| Remove the element of the head of the list and return it to the heap. --| If L is null EmptyList. --| Otherwise save the Next field of the first element, remove the first --| element and then assign to L the Next field of the first element. begin if L = null then raise EmptyList; else TempList := L.Next; Free (L); L := TempList; end if; end DeleteHead; -------------------------------------------------------------------------- procedure DeleteItem (L: in out List; Element: in Tree ) is Temp_L :List; --| Remove the first element in the list with the value Element. --| If the first element of the list is equal to element then --| remove it. Otherwise, recurse on the tail of the list. begin if L.Info = Element then DeleteHead(L); else DeleteItem(L.Next, Element); end if; exception when constraint_error => raise ItemNotPresent; end DeleteItem; -------------------------------------------------------------------------- procedure DeleteItems (L: in out List; Element: in Tree ) is Place_In_L :List; --| Current place in L. Last_Place_In_L :List; --| Last place in L. Temp_Place_In_L :List; --| Holds a place in L to be removed. Found :boolean := false; --| Indicates if an element with --| the correct value was found. --| Walk over the list removing all elements with the value Element. begin Place_In_L := L; Last_Place_In_L := null; while (Place_In_L /= null) loop --| Found an element equal to Element if Place_In_L.Info = Element then Found := true; --| If Last_Place_In_L is null then we are at first element --| in L. if Last_Place_In_L = null then Temp_Place_In_L := Place_In_L; L := Place_In_L.Next; else Temp_Place_In_L := Place_In_L; --| Relink the list Last's Next gets Place's Next Last_Place_In_L.Next := Place_In_L.Next; end if; --| Move Place_In_L to the next position in the list. --| Free the element. --| Do not update the last element in the list it remains the --| same. Place_In_L := Place_In_L.Next; Free (Temp_Place_In_L); else --| Update the last place in L and the place in L. Last_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end if; end loop; --| If we have not found an element raise an exception. if not Found then raise ItemNotPresent; end if; end DeleteItems; -------------------------------------------------------------------------- procedure Destroy (L: in out List) is Place_In_L: List; HoldPlace: List; --| Walk down the list removing all the elements and set the list to --| the empty list. begin Place_In_L := L; while Place_In_L /= null loop HoldPlace := Place_In_L; Place_In_L := Place_In_L.Next; Free (HoldPlace); end loop; L := null; end Destroy; -------------------------------------------------------------------------- function FirstValue (L: in List) return Tree is --| Return the first value in the list. begin if L = null then raise EmptyList; else return (L.Info); end if; end FirstValue; -------------------------------------------------------------------------- procedure Forword (I: in out ListIter) is --| Return the pointer to the next member of the list. Temp_L :List; begin Temp_L := List (I); I := ListIter (Temp_L.Next); end Forword; -------------------------------------------------------------------------- function IsInList (L: in List; Element: in Tree ) return boolean is Place_In_L: List; --| Check if Element is in L. If it is return true otherwise return false. begin Place_In_L := L; while Place_In_L /= null loop if Place_In_L.Info = Element then return true; end if; Place_In_L := Place_In_L.Next; end loop; return false; end IsInList; -------------------------------------------------------------------------- function IsEmpty (L: in List) return boolean is --| Is the list L empty. begin return (L = null); end IsEmpty; -------------------------------------------------------------------------- function LastValue (L: in List) return Tree is LastElement: List; --| Return the value of the last element of the list. Get the pointer --| to the last element of L and then return its information. begin LastElement := Last (L); return LastElement.Info; end LastValue; -------------------------------------------------------------------------- function Length (L: in List) return integer is --| Recursively compute the length of L. The length of a list is --| 0 if it is null or 1 + the length of the tail. begin if L = null then return (0); else return (1 + Length (Tail (L))); end if; end Length; -------------------------------------------------------------------------- function MakeListIter (L: in List) return ListIter is --| Start an iteration operation on the list L. Do a type conversion --| from List to ListIter. begin return ListIter (L); end MakeListIter; -------------------------------------------------------------------------- function More (L: in ListIter) return boolean is --| This is a test to see whether an iteration is complete. begin return L /= null; end; -------------------------------------------------------------------------- procedure Next (Place: in out ListIter; Info: out Tree ) is PlaceInList: List; --| This procedure gets the information at the current place in the List --| and moves the ListIter to the next postion in the list. --| If we are at the end of a list then exception NoMore is raised. begin if Place = null then raise NoMore; else PlaceInList := List(Place); Info := PlaceInList.Info; Place := ListIter(PlaceInList.Next); end if; end Next; -------------------------------------------------------------------------- procedure ReplaceHead (L: in out List; Info: in Tree ) is --| This procedure replaces the information at the head of a list --| with the given information. If the list is empty the exception --| EmptyList is raised. begin if L = null then raise EmptyList; else L.Info := Info; end if; end ReplaceHead; -------------------------------------------------------------------------- procedure ReplaceTail (L: in out List; NewTail: in List ) is Temp_L: List; --| This destroys the tail of a list and replaces the tail with --| NewTail. If L is empty EmptyList is raised. begin Destroy(L.Next); L.Next := NewTail; exception when constraint_error => raise EmptyList; end ReplaceTail; -------------------------------------------------------------------------- function Tail (L: in List) return List is --| This returns the list which is the tail of L. If L is null Empty --| List is raised. begin if L = null then raise EmptyList; else return L.Next; end if; end Tail; -------------------------------------------------------------------------- function Equal (List1: in List; List2: in List ) return boolean is PlaceInList1: List; PlaceInList2: List; Contents1: Tree; Contents2: Tree; --| This function tests to see if two lists are equal. Two lists --| are equal if for all the elements of List1 the corresponding --| element of List2 has the same value. Thus if the 1st elements --| are equal and the second elements are equal and so up to n. --| Thus a necessary condition for two lists to be equal is that --| they have the same number of elements. --| This function walks over the two list and checks that the --| corresponding elements are equal. As soon as we reach --| the end of a list (PlaceInList = null) we fall out of the loop. --| If both PlaceInList1 and PlaceInList2 are null after exiting the loop --| then the lists are equal. If they both are not null the lists aren't --| equal. Note that equality on elements is based on a user supplied --| function Equal which is used to test for item equality. begin PlaceInList1 := List1; PlaceInList2 := List2; while (PlaceInList1 /= null) and (PlaceInList2 /= null) loop if PlaceInList1.Info /= PlaceInList2.Info then return false; end if; PlaceInList1 := PlaceInList1.Next; PlaceInList2 := PlaceInList2.Next; end loop; return ((PlaceInList1 = null) and (PlaceInList2 = null) ); end Equal; end NodeOrder; -------------------------------------------------------------------------- ---------------------------------------------------------------------------- -- Local Subprograms ---------------------------------------------------------------------------- procedure Free is new unchecked_deallocation (Node, Tree); function equal (X, Y: in Member) return boolean is begin return (not (X < Y)) and (not (Y < X)); end; ------------------------------------------------------------------------------ function Generate (T :in Tree ) return Nodeorder.List is L : Nodeorder.List; --| This routine generates a list of pointers to nodes in the tree t. --| The list is ordered with respect to the order of the nodes in the tree. --| generate does a depth first search of the tree. --| 1. It first visits the leftchild of t and generates the list for that. --| 2. It then appends the root node of t to the list generated for the left --| child. --| 3. It then appends the list generated for the rightchild to the list --| generated for the leftchild and the root. --| begin L := NodeOrder.Create; if T /= null then L := Generate (T.Leftchild); Nodeorder.Attach (L, T); Nodeorder.Attach (L, Generate (T.Rightchild)); end if; return L; end Generate; ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Visible Subprograms ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ function Create return Tree is begin return null; end; ----------------------------------------------------------------------------- procedure Deposit ( I :in Member; S :in Tree ) is begin S.Info := I; end; ------------------------------------------------------------------------------ procedure DestroyTree ( T :in out Tree) is --| This procedure recursively destroys the tree T. --| 1. It destroy the leftchild of T --| 2. It then destroys the rightchild of T. --| 3. It then destroy the root T and set T to be null. begin if T /= null then DestroyTree (T.leftchild); DestroyTree (T.rightchild); Free (T); end if; end DestroyTree; ------------------------------------------------------------------------------ procedure InsertNode ( N :in out Member; --| Node being inserted. T :in out Tree; --| Tree node is being inserted --| into. Root : out Tree; --| Root of the subtree which node N --| heads. This is the position of --| node N in T; Exists : out boolean --| If this node already exists in --| the tree then Exists is true. If --| If this is the first insertion --| Exists is false. ) is --| This inserts the node N in T. --| 1. If T is null then a new node is allocated and assigned to T --| 2. If T is not null then T is searched for the proper place to insert n. --| This is first done by checking whether N < rightchild --| 3. If this is not true then we check to see if leftchild < N --| 4. If this is not true then N is in the tree. begin if T = null then T := new Node ' (Info => N, leftchild => null, rightchild => null); Root := T; Exists := false; N := T.Info; elsif N < T.Info then InsertNode (N, T.leftchild, Root, Exists); elsif T.Info < N then InsertNode (N, T.rightchild, Root, Exists); else Root := T; Exists := true; N := T.Info; end if; end InsertNode; ------------------------------------------------------------------------------ function MakeTreeIter (T :in Tree ) return TreeIter is I :TreeIter; --| This sets up the iterator for a tree T. --| The NodeList keeps track of the order of the nodes of T. The NodeList --| is computed by first invoking Generate of the leftchild then append --| the root node to NodeList and then append the result of Generate --| to NodeList. Since the tree is ordered such that --| --| leftchild < root root < rightchild --| --| NodeOrder returns the nodes in ascending order. --| --| Thus NodeList keeps the list alive for the duration of the iteration --| operation. The variable State is the a pointer into the NodeList --| which is the current place of the iteration. begin I.NodeList := NodeOrder.Create; if T /= null then I.NodeList := Generate (T.leftchild); NodeOrder.Attach (I.NodeList, T); NodeOrder.Attach (I.NodeList, Generate (T.rightChild)); end if; I.State := NodeOrder.MakeListIter (I.NodeList); return I; end; ------------------------------------------------------------------------------ function More (I :in TreeIter) return boolean is begin return NodeOrder.More (I.State); end; ------------------------------------------------------------------------------ procedure Next ( I :in out TreeIter; Info : out Member ) is T: Tree; --| Next returns the information at the current position in the iterator --| and increments the iterator. This is accomplished by using the iterater --| associated with the NodeOrder list. This returns a pointer into the Tree --| and then the information found at this node in T is returned. begin NodeOrder.Next (I.State, T); Info := T.Info; end; ------------------------------------------------------------------------------- end TreePkg; ------------------------------------------------------------------------------- -- Local Subprograms ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- function "<" ( --| Implements "<" for the type member. X :in Member; Y :in Member ) return boolean is begin return X.Info < Y.Info; end; ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- Visible Subprograms ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- function Cardinality ( S :in Set --| The set whose size is being computed. ) return natural is T :TreePkg.TreeIter; M :Member; count :natural := 0; begin T := TreePkg.MakeTreeIter (S.SetRep); while TreePkg.More (T) loop TreePkg.Next (T, M); count := count + 1; end loop; return count; end Cardinality; ------------------------------------------------------------------------------- function Create return Set is S :Set; begin S.SetRep := TreePkg.Create; return S; end Create; ------------------------------------------------------------------------------ procedure Destroy ( S :in out Set ) is begin TreePkg.DestroyTree (S.SetRep); end Destroy; ----------------------------------------------------------------------------- function GetCount ( I :in SetIter ) return natural is begin return I.Count; end; ----------------------------------------------------------------------------- procedure Insert( M :in DEF_ID.Locator; S :in out Set ) is Subtree :TreePkg.Tree; Exists :boolean; MemberToEnter :Member := ( Info => M, count => 1); begin --| If NewMember doesn't exist in SetRep it is added. If it does exist --| Exists comes back true and then M's count is updated. Since the --| first argument of TreePkg.Insert is in out, after Insert --| MemberToEnter has the value stored in the tree. Thus if we --| need to update the count we can simple bump the count in MemberToEnter. TreePkg.InsertNode (MemberToEnter, S.SetRep, SubTree, Exists); if Exists then MemberToEnter.Count := MemberToEnter.Count + 1; TreePkg.Deposit (MemberToEnter, SubTree); end if; end Insert; ------------------------------------------------------------------------------ function MakeSetIter ( S :in Set ) return SetIter is I :SetIter; begin I.Place := TreePkg.MakeTreeIter (S.SetRep); I.Count := 0; return I; end; ------------------------------------------------------------------------------ function More ( I :in SetIter ) return boolean is begin return TreePkg.More (I.Place); end; ------------------------------------------------------------------------------ procedure Next ( I :in out SetIter; M : out DEF_ID.Locator ) is TempMember :Member; begin TreePkg.Next (I.Place, TempMember); M := TempMember.Info; I.Count := TempMember.Count; end; ------------------------------------------------------------------------------ end DEF_ID_Set; package body BlockInfoStack is use Lists; function create return stack is begin return new stack_rec'(size => 0, elts => create); end create; procedure push(s: in out stack; e: BlockInfoType) is begin s.size := s.size + 1; s.elts := attach(e, s.elts); exception when constraint_error => raise uninitialized_stack; end push; procedure pop(s: in out stack) is begin DeleteHead(s.elts); s.size := s.size - 1; exception when EmptyList => raise empty_stack; when constraint_error => raise uninitialized_stack; end pop; procedure pop(s: in out stack; e: out BlockInfoType) is begin e := FirstValue(s.elts); DeleteHead(s.elts); s.size := s.size - 1; exception when EmptyList => raise empty_stack; when constraint_error => raise uninitialized_stack; end pop; function copy(s: stack) return stack is begin if s = null then raise uninitialized_stack; end if; return new stack_rec'(size => s.size, elts => copy(s.elts)); end; function top(s: stack) return BlockInfoType is begin return FirstValue(s.elts); exception when EmptyList => raise empty_stack; when constraint_error => raise uninitialized_stack; end top; function size(s: stack) return natural is begin return s.size; exception when constraint_error => raise uninitialized_stack; end size; function is_empty(s: stack) return boolean is begin return s.size = 0; exception when constraint_error => raise uninitialized_stack; end is_empty; procedure destroy(s: in out stack) is procedure free_stack is new unchecked_deallocation(stack_rec, stack); begin destroy(s.elts); free_stack(s); exception when constraint_error => -- stack is null return; end destroy; package body Lists is procedure Free is new unchecked_deallocation (Cell, List); function Last (L: in List) return List is Place_In_L: List; Temp_Place_In_L: List; begin if L = null then raise EmptyList; else --| Link down L saving the pointer to the previous element in --| Temp_Place_In_L. After the last iteration Temp_Place_In_L --| points to the last element in the list. Place_In_L := L; while Place_In_L /= null loop Temp_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end loop; return Temp_Place_In_L; end if; end Last; procedure Attach (List1: in out List; List2: in List ) is EndOfList1: List; --| Attach List2 to List1. --| If List1 is null return List2 --| If List1 equals List2 then raise CircularList --| Otherwise get the pointer to the last element of List1 and change --| its Next field to be List2. begin if List1 = null then List1 := List2; return; elsif List1 = List2 then raise CircularList; else EndOfList1 := Last (List1); EndOfList1.Next := List2; end if; end Attach; procedure Attach (L: in out List; Element: in BlockInfoType ) is NewEnd: List; begin NewEnd := new Cell'(Info => Element, Next => null); Attach (L, NewEnd); end; function Attach (Element1: in BlockInfoType; Element2: in BlockInfoType ) return List is NewList: List; begin NewList := new Cell'(Info => Element1, Next => null); Attach (NewList, Element2); return NewList; end; procedure Attach (Element: in BlockInfoType; L: in out List ) is begin L := new Cell'(Info => Element, Next => L); end; function Attach ( List1: in List; List2: in List ) return List is Last_Of_List1: List; begin if List1 = null then return List2; elsif List1 = List2 then raise CircularList; else Last_Of_List1 := Last (List1); Last_Of_List1.Next := List2; return List1; end if; end Attach; function Attach( L: in List; Element: in BlockInfoType ) return List is NewEnd: List; Last_Of_L: List; begin NewEnd := new Cell'(Info => Element, Next => null); if L = null then return NewEnd; else Last_Of_L := Last (L); Last_Of_L.Next := NewEnd; return L; end if; end Attach; function Attach (Element: in BlockInfoType; L: in List ) return List is begin return (new Cell'(Info => Element, Next => L)); end Attach; function Copy (L: in List) return List is begin if L = null then return null; else return new Cell'(Info => L.Info, Next => Copy (L.Next)); end if; end Copy; function Create return List is --| Return the empty list. begin return null; end Create; procedure DeleteHead (L: in out List) is TempList: List; begin if L = null then raise EmptyList; else TempList := L.Next; Free (L); L := TempList; end if; end DeleteHead; procedure DeleteItem (L: in out List; Element: in BlockInfoType ) is Temp_L :List; begin if L.Info = Element then DeleteHead(L); else DeleteItem(L.Next, Element); end if; exception when constraint_error => raise ItemNotPresent; end DeleteItem; procedure DeleteItems (L: in out List; Element: in BlockInfoType ) is Place_In_L :List; --| Current place in L. Last_Place_In_L :List; --| Last place in L. Temp_Place_In_L :List; --| Holds a place in L to be removed. Found :boolean := false; --| Indicates if an element with --| the correct value was found. begin Place_In_L := L; Last_Place_In_L := null; while (Place_In_L /= null) loop --| Found an element equal to Element if Place_In_L.Info = Element then Found := true; --| If Last_Place_In_L is null then we are at first element --| in L. if Last_Place_In_L = null then Temp_Place_In_L := Place_In_L; L := Place_In_L.Next; else Temp_Place_In_L := Place_In_L; --| Relink the list Last's Next gets Place's Next Last_Place_In_L.Next := Place_In_L.Next; end if; --| Move Place_In_L to the next position in the list. --| Free the element. --| Do not update the last element in the list it remains the --| same. Place_In_L := Place_In_L.Next; Free (Temp_Place_In_L); else --| Update the last place in L and the place in L. Last_Place_In_L := Place_In_L; Place_In_L := Place_In_L.Next; end if; end loop; if not Found then raise ItemNotPresent; end if; end DeleteItems; procedure Destroy (L: in out List) is Place_In_L: List; HoldPlace: List; begin Place_In_L := L; while Place_In_L /= null loop HoldPlace := Place_In_L; Place_In_L := Place_In_L.Next; Free (HoldPlace); end loop; L := null; end Destroy; function FirstValue (L: in List) return BlockInfoType is begin if L = null then raise EmptyList; else return (L.Info); end if; end FirstValue; procedure Forword (I: in out ListIter) is PlaceInList :List; begin PlaceInList := List (I); I := ListIter (PlaceInList.Next); end Forword; function IsInList (L: in List; Element: in BlockInfoType ) return boolean is Place_In_L: List; begin Place_In_L := L; while Place_In_L /= null loop if Place_In_L.Info = Element then return true; end if; Place_In_L := Place_In_L.Next; end loop; return false; end IsInList; function IsEmpty (L: in List) return boolean is --| Is the list L empty. begin return (L = null); end IsEmpty; function LastValue (L: in List) return BlockInfoType is LastElement: List; begin LastElement := Last (L); return LastElement.Info; end LastValue; function Length (L: in List) return integer is begin if L = null then return (0); else return (1 + Length (Tail (L))); end if; end Length; function MakeListIter (L: in List) return ListIter is begin return ListIter (L); end MakeListIter; function More (L: in ListIter) return boolean is begin return L /= null; end; procedure Next (Place: in out ListIter; Info: out BlockInfoType ) is PlaceInList: List; begin if Place = null then raise NoMore; else PlaceInList := List(Place); Info := PlaceInList.Info; Place := ListIter(PlaceInList.Next); end if; end Next; procedure ReplaceHead (L: in out List; Info: in BlockInfoType ) is begin if L = null then raise EmptyList; else L.Info := Info; end if; end ReplaceHead; procedure ReplaceTail (L: in out List; NewTail: in List ) is Temp_L: List; begin Destroy(L.Next); L.Next := NewTail; exception when constraint_error => raise EmptyList; end ReplaceTail; function Tail (L: in List) return List is --| This returns the list which is the tail of L. If L is null Empty --| List is raised. begin if L = null then raise EmptyList; else return L.Next; end if; end Tail; function Equal (List1: in List; List2: in List ) return boolean is PlaceInList1: List; PlaceInList2: LIst; Contents1: BlockInfoType; Contents2: BlockInfoType; --| This function tests to see if two lists are equal. Two lists --| are equal if for all the elements of List1 the corresponding --| element of List2 has the same value. Thus if the 1st elements --| are equal and the second elements are equal and so up to n. --| Thus a necessary condition for two lists to be equal is that --| they have the same number of elements. --| This function walks over the two list and checks that the --| corresponding elements are equal. As soon as we reach --| the end of a list (PlaceInList = null) we fall out of the loop. --| If both PlaceInList1 and PlaceInList2 are null after exiting the loop --| then the lists are equal. If they both are not null the lists aren't --| equal. Note that equality on elements is based on a user supplied --| function Equal which is used to test for item equality. begin PlaceInList1 := List1; PlaceInList2 := List2; while (PlaceInList1 /= null) and (PlaceInList2 /= null) loop if not "=" (PlaceInList1.Info, PlaceInList2.Info) then return false; end if; PlaceInList1 := PlaceInList1.Next; PlaceInList2 := PlaceInList2.Next; end loop; return ((PlaceInList1 = null) and (PlaceInList2 = null) ); end Equal; end Lists; end BlockInfoStack; end Definitions; :::::::::::::: defs.spc :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/defs.spc,v $ -- $Revision: 5.7 $ -- $Date: 85/09/04 09:24:19 $ -- $Author: buddy $ with ST_Diana; use ST_Diana; with ML_Source_Position_Pkg; package Definitions is --| OVERVIEW --| This package defines all the data used by the Halstead program. This --| package also defines all the operations on the data types defined. --| The following is a list of all the abstract data types which --| this package defines. --| --| --| 1. DEF_ID_Set.Set from the package DEF_ID_Set --| 2. Literal_Set.Set from the package Literal_Set --| 3. BlockInfoStack.Stack from the package BlockInfoStack --| --| The types defined here are all used to create the BlockInfoType. --| BlockInfoType keeps all the information pertaining to current block --| being processed. The type is composed of four components types which --| are: --| 1. TokenCountType --| 2. BlockIdType --| 3. Literal_Set.Set --| 4. DEF_ID_Set.Set --| --| TokenCountType keeps track of the number of times each token appears --| in the source program. --| --| BlockIdType maintains the name of the current block being --| processed, whether the block is a body or a spec, and --| the type of block whether its a procedure, package... --| --| Literal_Set This keeps a counted set of all the literals --| appearing in a given block. These literals will be --| counted as operands. --| --| DEF_ID_Set.Set This keeps a list of all the identifiers encounted --| in a block. At the end of the block all the --| identifiers are categorized into operands and --| operators. --| EFFECTS --| Associated with the three abstract data types DEF_ID_Set.Set --| Literal_Set.Set and BlockInfo.Stack are a complete set of --| operations. --| --| The operations associated with the sets DEF_ID_Set.Set and --| Literal_Set.Set are counted sets. This means that a member in the --| set has a count associated with it. Each time an insert is done --| on a member the count for the member is incremented. --| --| The operations associated with BlockInfoStack are the normal --| stack operations Push, Pop and some others. These operations are --| used to stack the information associated with a block. --| TUNING --| One way to tune this package is to cut out a lot of the functions --| which are not used. For example the users of this package do not --| use FirstValue and some of the other operations of the list package. type TokenItem is ( abortz, acceptz, accessz, allz, and_thenz, arrayz, atz, beginz, bodyz, body_packagez, body_taskz, casez, case_stmz, case_variantz, constantz, declarez, delayz, deltaz, digitsz, doz, elsez, else_ifz, else_orz, else_selectz, elsifz, endz, end_acceptz, end_beginz, end_case_stmz, end_case_variantz, end_ifz, end_loopz, end_package_bdyz, end_package_spcz, end_recordz, end_record_repz, end_selectz, end_task_spcz, entryz, exceptionz, exitz, forz, for_loopz, for_repz, functionz, genericz, gotoz, ifz, inz, in_loopz, in_membershipz, in_out_parameterz, in_parameterz, isz, is_case_stmz, is_case_variantz, is_functionz, is_genericz, is_package_bdyz, is_package_spcz, is_procedurez, is_separatez, is_subtypez, is_typez, is_task_bdyz, is_task_spcz, limitedz, loopz, modz, newz, new_allocatorz, new_derived_typez, new_generic_instz, not_in_membershipz, nullz, null_valuez, null_stmz, null_fieldz, ofz, orz, or_elsez, or_selectz, othersz, others_aggregatez, others_casez, others_exceptionz, others_variantz, outz, packagez, package_bdyz, package_spcz, pragmaz, privatez, private_sectionz, private_typez, procedurez, raisez, rangez, recordz, record_typez, record_repz, renamesz, returnz, reversez, selectz, separatez, subtypez, taskz, task_bdyz, task_spcz, terminatez, thenz, then_andz, typez, usez, use_contextz, use_repz, whenz, when_case_stmz, when_exitz, when_exceptionz, when_selectz, when_case_variantz, whilez, withz, with_contextz, with_genericz, ------------- punctuation -------------- arrowz, barz, boxz, box_rangez, box_default_subpz, character_literalz, closed_anglesz, closed_parenthesisz, colon_equalsz, colonz, commaz, dotz, dot_dot_rangez, double_quotez, numeric_literalz, open_anglesz, open_parenthesisz, semicolonz, single_quotez, tickz, declare_blockz ); --| These are all the tokens which could possibly be counted by --| Halstead. type Class is (operator, operand, neither); --| These are the different ways to classify symbols in the source --| program. type TokenCountType is array(TokenItem) of natural; --| This type is used to count the occurrences of each token --| in the source program. type TokenClassificationType is array(TokenItem) of Class; --| This type is used to defined whether tokens are operators --| or operands or neither. type BlockKind is ( procedure_block, function_block, package_body_block, package_spec_block, task_body_block, task_spec_block, declare_block ); --| This keeps track of the type of block being processed currently. BlockNameLength: constant := 16; --| Maximum length of a block name. SpcBdyIdLength: constant := 13; --| Maximum lenght of a string which indicates whether a block --| is a spec, body, or declare block. subtype SpcBdyIdType is string(1..SpcBdyIdLength); AnonId :constant SpcBdyIdType := " "; BdyId :constant SpcBdyIdType := "BODY "; DecId :constant SpcBdyIdType := "DECLARE BLOCK"; SpcId :constant SpcBdyIdType := "SPECIFICATION"; --| These are used to initialize the SpcOrBdyId field of --| BlockIdType. type StringPtr is access String; --| This is used to keep track of the fully qualified name of the --| block being processed. Each time a new scope is entered --| the name of that scope is concatenated with the current --| fully qualified name. type BlockIdType is record KindOfBlock :BlockKind; SpcBdyId :SpcBdyIdType; BlockName :StringPtr; LineLocation :ML_Source_Position_Pkg.Source_Line; end record; --| This type keeps track of the name of a block. For instance --| if we are processing the body of procedure P then the name --| of the block is P. The KindOfBlock is "PROCEDURE" and --| SpcOrBdyId = "(B)". --| The following code represents a generic instantiation of the --| OrderedSet package. It replaces: --| --| package DEF_ID_Set is new OrderedSet --| (ItemType => DEF_ID.Locator, --| "<" => ST_Diana.DEF_ID."<"); -------------------------------------------------------------------------- -- GENERIC INSTANTIATION -------------------------------------------------------------------------- function "<" ( X, Y: DEF_ID.Locator) return boolean renames ST_Diana.DEF_ID."<"; package DEF_ID_Set is --| Overview --| This abstractions is a counted ordered set. This means that --| associated with each member of the set is a count of the number of --| times it appears in the set. The order part means that there is --| an ordering associated with the members. This allows fast insertion. --| It also makes it easy to iterate over the set in order. -- Types -- ----- type Set is private; --| This is the type exported to represent --| the ordered set. type SetIter is private; --| This is the type exported whose --| purpose is to walk over a set. -- Operations -- ---------- --| Cardinality Returns cardinality of the set. --| Create Creates the empty set. --| CountMember Returns the number of times the member appears in --| the set. --| Destroy Destroys a set and returns the space it occupies. --| Insert Insert a member into the set. --| MakeSetIter Return a SetIter which will begin an iteration. --| More Are there more elements to iterate over in the --| set. --| Next Return the next element in the iteration and --| bump the iterator. ------------------------------------------------------------------------------ function Cardinality ( --| Return the number of members in the set. S :in Set --| The set whose members are being counted. ) return natural; ------------------------------------------------------------------------------ function Create --| Return the empty set. return Set; ------------------------------------------------------------------------------ procedure Destroy ( --| Destroy a set and return its space. S :in out Set --| Set being destroyed. ); ------------------------------------------------------------------------------ function GetCount ( --| This returns the count associated with --| member which corresponds to the current --| iterator I. I :in SetIter ) return natural; ----------------------------------------------------------------------------- procedure Insert ( --| Insert a member M into set S. M :in DEF_ID.Locator; --| Member being inserted. S :in out Set --| Set being inserted into. ); ------------------------------------------------------------------------------ function MakeSetIter ( --| Prepares a user for an iteration operation by --| by returning a SetIter. S :in Set --| Set being iterate over. ) return SetIter; ------------------------------------------------------------------------------ function More ( --| Returns true if there are more elements in the --| set to iterate over. I :in SetIter --| The iterator. ) return boolean; ------------------------------------------------------------------------------ procedure Next ( --| Returns the current member in the iteration --| an increments the iterator. I :in out SetIter; --| The iterator. M : out DEF_ID.Locator --| The current member being returned. ); ----------------------------------------------------------------------------- private type Member is record Info :DEF_ID.Locator; Count :natural; end record; function "<" ( X:in Member; Y:in Member ) return boolean; -- generic instantiation --package TreePkg is new BinaryTrees ( DEF_ID.Locator => Member, "<" => "<" ); package TreePkg is --| Overview --| This package creates an ordered binary tree. This will allow for --| quick insertion, and search. --| --| The tree is organized such that --| --| leftchild < root root < rightchild --| --| This means that by doing a left to right search of the tree will can --| produce the nodes of the tree in ascending order. -- Types -- ----- type Tree is private; --| This is the type exported to represent the --| tree. type TreeIter is private; --| This is the type which is used to iterate --| over the set. --| Exceptions --| ---------- --| Operations --| ---------- --| --| Create Creates a tree. --| Deposit Replaces the given node's information with --| the given information. --| DestroyTree Destroys the given tree and returns the spaces. --| InsertNode This inserts a node n into a tree t. --| MakeTreeIter This returns an iterator to the user in order to start --| an iteration. --| More This returns true if there are more elements to iterate --| over in the tree. --| Next This returns the information associated with the current --| iterator and advances the iterator. --------------------------------------------------------------------------- function Create --| This function creates the tree. return Tree; --| Effects --| This creates a tree containing no information and no children. An --| emptytree. ------------------------------------------------------------------------------- procedure Deposit ( --| This deposits the information I in the --| root of the Tree S. I :in Member; --| The information being deposited. S :in Tree --| The tree where the information is being --| stored. ); --| Modifies --| This changes the information stored at the root of the tree S. ------------------------------------------------------------------------------- procedure DestroyTree ( --| Destroys a tree. T :in out Tree --| Tree being destroyed. ); --| Effects --| Destroys a tree and returns the space which it is occupying. -------------------------------------------------------------------------- Procedure Insertnode( --| This Procedure Inserts A Node Into The --| Specified Tree. N :In Out Member; --| The Information To Be Contained In The --| Node Being Inserted. T :In Out Tree; --| Tree Being Inserted Into. Root : Out Tree; --| Root of the subtree which Node N heads. --| This is the position of the node N in T. Exists : out boolean --| If this node already exists in the tree --| Exists is true. If this is the first --| insertion Exists is false. ); --| Effects --| This adds the node N to the tree T inserting in the proper postion. --| Modifies --| This modifies the tree T by add the node N to it. ------------------------------------------------------------------------------ function MakeTreeIter ( --| Sets a variable to a position in the --| tree --| where the iteration is to begin. In this --| case the position is a pointer to the --| the deepest leftmost leaf in the tree. T:in Tree --| Tree being iterated over ) return TreeIter; --| Effects ----------------------------------------------------------------------------- function More ( --| Returns true if there are more elements --| in the tree to iterate over. I :in TreeIter ) return boolean; ----------------------------------------------------------------------------- procedure Next ( --| This is the iterator operation. Given --| an Iter in the Tree it returns the --| item Iter points to and updates the --| iter. If Iter is at the end of the Tree, --| yielditer returns false otherwise it --| returns true. I :in out TreeIter; --| The iter which marks the position in the --| Tree. Info : out Member --| Information being returned from a node. ); --------------------------------------------------------------------------- private type Node; type Tree is access Node; type Node is record Info :Member; LeftChild :Tree; RightChild :Tree; end record; --- The following is a generic instantiation of NodeOrder --- package NodeOrder is new Lists (Tree); package NodeOrder is --| This package provides singly linked lists with elements of type --| Tree, where Tree is specified by a generic parameter. --| Overview --| When this package is instantiated, it provides a linked list type for --| lists of objects of type Tree, which can be any desired type. A --| complete set of operations for manipulation, and releasing --| those lists is also provided. For instance, to make lists of strings, --| all that is necessary is: --| --| type StringType is string(1..10); --| --| package Str_List is new Lists(StringType); use Str_List; --| --| L:List; --| S:StringType; --| --| Then to add a string S, to the list L, all that is necessary is --| --| L := Create; --| Attach(S,L); --| --| --| This package provides basic list operations. --| --| Attach append an object to an object, an object to a list, --| or a list to an object, or a list to a list. --| Copy copy a list using := on elements --| CopyDeep copy a list by copying the elements using a copy --| operation provided by the user --| Create Creates an empty list --| DeleteHead removes the head of a list --| DeleteItem delete the first occurrence of an element from a list --| DeleteItems delete all occurrences of an element from a list --| Destroy remove a list --| Equal are two lists equal --| FirstValue get the information from the first element of a list --| IsInList determines whether a given element is in a given list --| IsEmpty returns true if the list is empty --| LastValue return the last value of a list --| Length Returns the length of a list --| MakeListIter prepares for an iteration over a list --| More are there any more items in the list --| Next get the next item in a list --| ReplaceHead replace the information at the head of the list --| ReplaceTail replace the tail of a list with a new list --| Tail get the tail of a list --| --| N/A: Effects, Requires, Modifies, and Raises. --| Notes --| Programmer Buddy Altus --| Types --| ----- type List is private; type ListIter is private; --| Exceptions --| ---------- CircularList :exception; --| Raised if an attemp is made to --| create a circular list. This --| results when a list is attempted --| to be attached to itself. EmptyList :exception; --| Raised if an attemp is made to --| manipulate an empty list. ItemNotPresent :exception; --| Raised if an attempt is made to --| remove an element from a list in --| which it does not exist. NoMore :exception; --| Raised if an attemp is made to --| get the next element from a list --| after iteration is complete. --| Operations --| ---------- ---------------------------------------------------------------------------- procedure Attach( --| appends List2 to List1 List1: in out List; --| The list being appended to. List2: in List --| The list being appended. ); --| Raises --| CircularList --| Effects --| Appends List1 to List2. This makes the next field of the last element --| of List1 refer to List2. This can possibly change the value of List1 --| if List1 is an empty list. This causes sharing of lists. Thus if --| user Destroys List1 then List2 will be a dangling reference. --| This procedure raises CircularList if List1 equals List2. If it is --| necessary to Attach a list to itself first make a copy of the list and --| attach the copy. --| Modifies --| Changes the next field of the last element in List1 to be List2. ------------------------------------------------------------------------------- function Attach( --| Creates a new list containing the two --| Elements. Element1: in Tree; --| This will be first element in list. Element2: in Tree --| This will be second element in list. ) return List; --| Effects --| This creates a list containing the two elements in the order --| specified. ------------------------------------------------------------------------------- procedure Attach( --| List L is appended with Element. L: in out List; --| List being appended to. Element: in Tree --| This will be last element in l ist. ); --| Effects --| Appends Element onto the end of the list L. If L is empty then this --| may change the value of L. --| --| Modifies --| This appends List L with Element by changing the next field in List. -------------------------------------------------------------------------------- procedure Attach( --| Makes Element first item in list L. Element: in Tree; --| This will be the first element in list. L: in out List --| The List which Element is being --| prepended to. ); --| Effects --| This prepends list L with Element. --| --| Modifies --| This modifies the list L. -------------------------------------------------------------------------- function Attach ( --| attaches two lists List1: in List; --| first list List2: in List --| second list ) return List; --| Raises --| CircularList --| Effects --| This returns a list which is List1 attached to List2. If it is desired --| to make List1 be the new attached list the following ada code should be --| used. --| --| List1 := Attach (List1, List2); --| This procedure raises CircularList if List1 equals List2. If it is --| necessary to Attach a list to itself first make a copy of the list and --| attach the copy. ------------------------------------------------------------------------- function Attach ( --| prepends an element onto a list Element: in Tree; --| element being prepended to list L: in List --| List which element is being added --| to ) return List; --| Effects --| Returns a new list which is headed by Element and followed by L. ------------------------------------------------------------------------ function Attach ( --| Adds an element to the end of a list L: in List; --| The list which element is being added to. Element: in Tree --| The element being added to the end of --| the list. ) return List; --| Effects --| Returns a new list which is L followed by Element. -------------------------------------------------------------------------- function Copy( --| returns a copy of list1 L: in List --| list being copied ) return List; --| Effects --| Returns a copy of L. -------------------------------------------------------------------------- function Create --| Returns an empty List return List; ------------------------------------------------------------------------------ procedure DeleteHead( --| Remove the head element from a list. L: in out List --| The list whose head is being removed. ); --| Raises --| EmptyList --| --| Effects --| This will return the space occupied by the first element in the list --| to the heap. If sharing exists between lists this procedure --| could leave a dangling reference. If L is empty EmptyList will be --| raised. ------------------------------------------------------------------------------ procedure DeleteItem( --| remove the first occurrence of Element --| from L L: in out List; --| list element is being removed from Element: in Tree --| element being removed ); --| Raises --| ItemNotPresent --| Effects --| Removes the first element of the list equal to Element. If there is --| not an element equal to Element than ItemNotPresent is raised. --| Modifies --| This operation is destructive, it returns the storage occupied by --| the elements being deleted. ------------------------------------------------------------------------------ procedure DeleteItems( --| remove all occurrences of Element --| from L. L: in out List; --| The List element is being removed from Element: in Tree --| element being removed ); --| Raises --| ItemNotPresent --| --| Effects --| This procedure walks down the list L and removes all elements of the --| list equal to Element. If there are not any elements equal to Element --| then raise ItemNotPresent. --| Modifies --| This operation is destructive the storage occupied by the items --| removed is returned. ------------------------------------------------------------------------------ procedure Destroy( --| removes the list L: in out List --| the list being removed ); --| Effects --| This returns to the heap all the storage that a list occupies. Keep in --| mind if there exists sharing between lists then this operation can leave --| dangling references. ------------------------------------------------------------------------------ function FirstValue( --| returns the contents of the first record of the --| list L: in List --| the list whose first element is being --| returned ) return Tree; --| Raises --| EmptyList --| --| Effects --| This returns the Item in the first position in the list. If the list --| is empty EmptyList is raised. ------------------------------------------------------------------------------- function IsEmpty( --| Checks if a list is empty. L: in List --| List being checked. ) return boolean; -------------------------------------------------------------------------- function IsInList( --| Checks if element is an element of --| list. L: in List; --| list being scanned for element Element: in Tree --| element being searched for ) return boolean; --| Effects --| Walks down the list L looking for an element whose value is Element. ------------------------------------------------------------------------------ function LastValue( --| Returns the contents of the last record of --| the list. L: in List --| The list whose first element is being --| returned. ) return Tree; --| Raises --| EmptyList --| --| Effects --| Returns the last element in a list. If the list is empty EmptyList is --| raised. ------------------------------------------------------------------------------ function Length( --| count the number of elements on a list L: in List --| list whose length is being computed ) return integer; ------------------------------------------------------------------------------ function MakeListIter( --| Sets a variable to point to the head --| of the list. This will be used to --| prepare for iteration over a list. L: in List --| The list being iterated over. ) return ListIter; --| This prepares a user for iteration operation over a list. The iterater is --| an operation which returns successive elements of the list on successive --| calls to the iterator. There needs to be a mechanism which marks the --| position in the list, so on successive calls to the Next operation the --| next item in the list can be returned. This is the function of the --| MakeListIter and the type ListIter. MakeIter just sets the Iter to the --| the beginning of the list. On subsequent calls to NextList the Iter --| is updated with each call. ----------------------------------------------------------------------------- function More( --| Returns true if there are more elements in --| the and false if there aren't any more --| the in the list. L: in ListIter --| List being checked for elements. ) return boolean; ------------------------------------------------------------------------------ procedure Next( --| This is the iterator operation. Given --| a ListIter in the list it returns the --| current item and updates the ListIter. --| If ListIter is at the end of the list, --| More returns false otherwise it --| returns true. Place: in out ListIter; --| The Iter which marks the position in --| the list. Info: out Tree --| The element being returned. ); --| The iterators subprograms MakeListIter, More, and NextList should be used --| in the following way: --| --| L: List; --| Place: ListIter; --| Info: SomeType; --| --| --| Place := MakeListIter(L); --| --| while ( More(Place) ) loop --| NextList(Place, Info); --| process each element of list L; --| end loop; ---------------------------------------------------------------------------- procedure ReplaceHead( --| Replace the Item at the head of the list --| with the parameter Item. L: in out List; --| The list being modified. Info: in Tree --| The information being entered. ); --| Raises --| EmptyList --| Effects --| Replaces the information in the first element in the list. Raises --| EmptyList if the list is empty. ------------------------------------------------------------------------------ procedure ReplaceTail( --| Replace the Tail of a list --| with a new list. L: in out List; --| List whose Tail is replaced. NewTail: in List --| The list which will become the --| tail of Oldlist. ); --| Raises --| EmptyList --| --| Effects --| Replaces the tail of a list with a new list. If the list whose tail --| is being replaced is null EmptyList is raised. ------------------------------------------------------------------------------- function Tail( --| returns the tail of a list L L: in List --| the list whose tail is being returned ) return List; --| Raises --| EmptyList --| --| Effects --| Returns a list which is the tail of the list L. Raises EmptyList if --| L is empty. If L only has one element then Tail returns the Empty --| list. ------------------------------------------------------------------------------ function Equal( --| compares list1 and list2 for equality List1: in List; --| first list List2: in List --| second list ) return boolean; --| Effects --| Returns true if for all elements of List1 the corresponding element --| of List2 has the same value. This function uses the Equal operation --| provided by the user. If one is not provided then = is used. ------------------------------------------------------------------------------ private type Cell; type List is access Cell; --| pointer added by this package --| in order to make a list type Cell is --| Cell for the lists being created record Info: Tree; Next: List; end record; type ListIter is new List; --| This prevents Lists being assigned to --| iterators and vice versa end NodeOrder; type TreeIter is record NodeList :NodeOrder.List; State :NodeOrder.ListIter; end record; end TreePkg; type Set is record SetRep :TreePkg.Tree; end record; type SetIter is record Place :TreePkg.TreeIter; Count :natural; end record; end DEF_ID_Set; function "<" ( --| This is used to order the Source_Text.Locs X :in Source_Text.Locator; Y :in Source_Text.Locator ) return boolean; -- generic -- type Source_Text.Locator is private; -- with function "<" ( X ,Y: in Source_Text.Locator) return boolean; package Literal_Set is --| Overview --| This abstractions is a counted ordered set. This means that --| associated with each member of the set is a count of the number of --| times it appears in the set. The order part means that there is --| an ordering associated with the members. This allows fast insertion. --| It also makes it easy to iterate over the set in order. -- Types -- ----- type Set is private; --| This is the type exported to represent --| the ordered set. type SetIter is private; --| This is the type exported whose --| purpose is to walk over a set. -- Operations -- ---------- --| Cardinality Returns cardinality of the set. --| Create Creates the empty set. --| CountMember Returns the number of times the member appears in --| the set. --| Destroy Destroys a set and returns the space it occupies. --| Insert Insert a member into the set. --| MakeSetIter Return a SetIter which will begin an iteration. --| More Are there more elements to iterate over in the --| set. --| Next Return the next element in the iteration and --| bump the iterator. ------------------------------------------------------------------------------ function Cardinality ( --| Return the number of members in the set. S :in Set --| The set whose members are being counted. ) return natural; ------------------------------------------------------------------------------ function Create --| Return the empty set. return Set; ------------------------------------------------------------------------------ procedure Destroy ( --| Destroy a set and return its space. S :in out Set --| Set being destroyed. ); ------------------------------------------------------------------------------ function GetCount ( --| This returns the count associated with --| member which corresponds to the current --| iterator I. I :in SetIter ) return natural; ----------------------------------------------------------------------------- procedure Insert ( --| Insert a member M into set S. M :in Source_Text.Locator; --| Member being inserted. S :in out Set --| Set being inserted into. ); ------------------------------------------------------------------------------ function MakeSetIter ( --| Prepares a user for an iteration operation by --| by returning a SetIter. S :in Set --| Set being iterate over. ) return SetIter; ------------------------------------------------------------------------------ function More ( --| Returns true if there are more elements in the --| set to iterate over. I :in SetIter --| The iterator. ) return boolean; ------------------------------------------------------------------------------ procedure Next ( --| Returns the current member in the iteration --| an increments the iterator. I :in out SetIter; --| The iterator. M : out Source_Text.Locator --| The current member being returned. ); ----------------------------------------------------------------------------- private type Member is record Info :Source_Text.Locator; Count :natural; end record; function "<" ( X:in Member; Y:in Member ) return boolean; -- generic instantiation --package TreePkg is new BinaryTrees ( Source_Text.Locator => Member, "<" => "<" ); package TreePkg is --| Overview --| This package creates an ordered binary tree. This will allow for --| quick insertion, and search. --| --| The tree is organized such that --| --| leftchild < root root < rightchild --| --| This means that by doing a left to right search of the tree will can --| produce the nodes of the tree in ascending order. -- Types -- ----- type Tree is private; --| This is the type exported to represent the --| tree. type TreeIter is private; --| This is the type which is used to iterate --| over the set. --| Exceptions --| ---------- --| Operations --| ---------- --| --| Create Creates a tree. --| Deposit Replaces the given node's information with --| the given information. --| DestroyTree Destroys the given tree and returns the spaces. --| InsertNode This inserts a node n into a tree t. --| MakeTreeIter This returns an iterator to the user in order to start --| an iteration. --| More This returns true if there are more elements to iterate --| over in the tree. --| Next This returns the information associated with the current --| iterator and advances the iterator. --------------------------------------------------------------------------- function Create --| This function creates the tree. return Tree; --| Effects --| This creates a tree containing no information and no children. An --| emptytree. ------------------------------------------------------------------------------- procedure Deposit ( --| This deposits the information I in the --| root of the Tree S. I :in Member; --| The information being deposited. S :in Tree --| The tree where the information is being --| stored. ); --| Modifies --| This changes the information stored at the root of the tree S. ------------------------------------------------------------------------------- procedure DestroyTree ( --| Destroys a tree. T :in out Tree --| Tree being destroyed. ); --| Effects --| Destroys a tree and returns the space which it is occupying. -------------------------------------------------------------------------- Procedure Insertnode( --| This Procedure Inserts A Node Into The --| Specified Tree. N :In Out Member; --| The Information To Be Contained In The --| Node Being Inserted. T :In Out Tree; --| Tree Being Inserted Into. Root : Out Tree; --| Root of the subtree which Node N heads. --| This is the position of the node N in T. Exists : out boolean --| If this node already exists in the tree --| Exists is true. If this is the first --| insertion Exists is false. ); --| Effects --| This adds the node N to the tree T inserting in the proper postion. --| Modifies --| This modifies the tree T by add the node N to it. ------------------------------------------------------------------------------ function MakeTreeIter ( --| Sets a variable to a position in the --| tree --| where the iteration is to begin. In this --| case the position is a pointer to the --| the deepest leftmost leaf in the tree. T:in Tree --| Tree being iterated over ) return TreeIter; --| Effects ----------------------------------------------------------------------------- function More ( --| Returns true if there are more elements --| in the tree to iterate over. I :in TreeIter ) return boolean; ----------------------------------------------------------------------------- procedure Next ( --| This is the iterator operation. Given --| an Iter in the Tree it returns the --| item Iter points to and updates the --| iter. If Iter is at the end of the Tree, --| yielditer returns false otherwise it --| returns true. I :in out TreeIter; --| The iter which marks the position in the --| Tree. Info : out Member --| Information being returned from a node. ); --------------------------------------------------------------------------- private type Node; type Tree is access Node; type Node is record Info :Member; LeftChild :Tree; RightChild :Tree; end record; --- The following is a generic instantiation of NodeOrder --- package NodeOrder is new Lists (Tree); package NodeOrder is --| This package provides singly linked lists with elements of type --| Tree, where Tree is specified by a generic parameter. --| Overview --| When this package is instantiated, it provides a linked list type for --| lists of objects of type Tree, which can be any desired type. A --| complete set of operations for manipulation, and releasing --| those lists is also provided. For instance, to make lists of strings, --| all that is necessary is: --| --| type StringType is string(1..10); --| --| package Str_List is new Lists(StringType); use Str_List; --| --| L:List; --| S:StringType; --| --| Then to add a string S, to the list L, all that is necessary is --| --| L := Create; --| Attach(S,L); --| --| --| This package provides basic list operations. --| --| Attach append an object to an object, an object to a list, --| or a list to an object, or a list to a list. --| Copy copy a list using := on elements --| CopyDeep copy a list by copying the elements using a copy --| operation provided by the user --| Create Creates an empty list --| DeleteHead removes the head of a list --| DeleteItem delete the first occurrence of an element from a list --| DeleteItems delete all occurrences of an element from a list --| Destroy remove a list --| Equal are two lists equal --| FirstValue get the information from the first element of a list --| IsInList determines whether a given element is in a given list --| IsEmpty returns true if the list is empty --| LastValue return the last value of a list --| Length Returns the length of a list --| MakeListIter prepares for an iteration over a list --| More are there any more items in the list --| Next get the next item in a list --| ReplaceHead replace the information at the head of the list --| ReplaceTail replace the tail of a list with a new list --| Tail get the tail of a list --| --| N/A: Effects, Requires, Modifies, and Raises. --| Notes --| Programmer Buddy Altus --| Types --| ----- type List is private; type ListIter is private; --| Exceptions --| ---------- CircularList :exception; --| Raised if an attemp is made to --| create a circular list. This --| results when a list is attempted --| to be attached to itself. EmptyList :exception; --| Raised if an attemp is made to --| manipulate an empty list. ItemNotPresent :exception; --| Raised if an attempt is made to --| remove an element from a list in --| which it does not exist. NoMore :exception; --| Raised if an attemp is made to --| get the next element from a list --| after iteration is complete. --| Operations --| ---------- ---------------------------------------------------------------------------- procedure Attach( --| appends List2 to List1 List1: in out List; --| The list being appended to. List2: in List --| The list being appended. ); --| Raises --| CircularList --| Effects --| Appends List1 to List2. This makes the next field of the last element --| of List1 refer to List2. This can possibly change the value of List1 --| if List1 is an empty list. This causes sharing of lists. Thus if --| user Destroys List1 then List2 will be a dangling reference. --| This procedure raises CircularList if List1 equals List2. If it is --| necessary to Attach a list to itself first make a copy of the list and --| attach the copy. --| Modifies --| Changes the next field of the last element in List1 to be List2. ------------------------------------------------------------------------------- function Attach( --| Creates a new list containing the two --| Elements. Element1: in Tree; --| This will be first element in list. Element2: in Tree --| This will be second element in list. ) return List; --| Effects --| This creates a list containing the two elements in the order --| specified. ------------------------------------------------------------------------------- procedure Attach( --| List L is appended with Element. L: in out List; --| List being appended to. Element: in Tree --| This will be last element in l ist. ); --| Effects --| Appends Element onto the end of the list L. If L is empty then this --| may change the value of L. --| --| Modifies --| This appends List L with Element by changing the next field in List. -------------------------------------------------------------------------------- procedure Attach( --| Makes Element first item in list L. Element: in Tree; --| This will be the first element in list. L: in out List --| The List which Element is being --| prepended to. ); --| Effects --| This prepends list L with Element. --| --| Modifies --| This modifies the list L. -------------------------------------------------------------------------- function Attach ( --| attaches two lists List1: in List; --| first list List2: in List --| second list ) return List; --| Raises --| CircularList --| Effects --| This returns a list which is List1 attached to List2. If it is desired --| to make List1 be the new attached list the following ada code should be --| used. --| --| List1 := Attach (List1, List2); --| This procedure raises CircularList if List1 equals List2. If it is --| necessary to Attach a list to itself first make a copy of the list and --| attach the copy. ------------------------------------------------------------------------- function Attach ( --| prepends an element onto a list Element: in Tree; --| element being prepended to list L: in List --| List which element is being added --| to ) return List; --| Effects --| Returns a new list which is headed by Element and followed by L. ------------------------------------------------------------------------ function Attach ( --| Adds an element to the end of a list L: in List; --| The list which element is being added to. Element: in Tree --| The element being added to the end of --| the list. ) return List; --| Effects --| Returns a new list which is L followed by Element. -------------------------------------------------------------------------- function Copy( --| returns a copy of list1 L: in List --| list being copied ) return List; --| Effects --| Returns a copy of L. -------------------------------------------------------------------------- function Create --| Returns an empty List return List; ------------------------------------------------------------------------------ procedure DeleteHead( --| Remove the head element from a list. L: in out List --| The list whose head is being removed. ); --| Raises --| EmptyList --| --| Effects --| This will return the space occupied by the first element in the list --| to the heap. If sharing exists between lists this procedure --| could leave a dangling reference. If L is empty EmptyList will be --| raised. ------------------------------------------------------------------------------ procedure DeleteItem( --| remove the first occurrence of Element --| from L L: in out List; --| list element is being removed from Element: in Tree --| element being removed ); --| Raises --| ItemNotPresent --| Effects --| Removes the first element of the list equal to Element. If there is --| not an element equal to Element than ItemNotPresent is raised. --| Modifies --| This operation is destructive, it returns the storage occupied by --| the elements being deleted. ------------------------------------------------------------------------------ procedure DeleteItems( --| remove all occurrences of Element --| from L. L: in out List; --| The List element is being removed from Element: in Tree --| element being removed ); --| Raises --| ItemNotPresent --| --| Effects --| This procedure walks down the list L and removes all elements of the --| list equal to Element. If there are not any elements equal to Element --| then raise ItemNotPresent. --| Modifies --| This operation is destructive the storage occupied by the items --| removed is returned. ------------------------------------------------------------------------------ procedure Destroy( --| removes the list L: in out List --| the list being removed ); --| Effects --| This returns to the heap all the storage that a list occupies. Keep in --| mind if there exists sharing between lists then this operation can leave --| dangling references. ------------------------------------------------------------------------------ function FirstValue( --| returns the contents of the first record of the --| list L: in List --| the list whose first element is being --| returned ) return Tree; --| Raises --| EmptyList --| --| Effects --| This returns the Item in the first position in the list. If the list --| is empty EmptyList is raised. ------------------------------------------------------------------------------- function IsEmpty( --| Checks if a list is empty. L: in List --| List being checked. ) return boolean; -------------------------------------------------------------------------- function IsInList( --| Checks if element is an element of --| list. L: in List; --| list being scanned for element Element: in Tree --| element being searched for ) return boolean; --| Effects --| Walks down the list L looking for an element whose value is Element. ------------------------------------------------------------------------------ function LastValue( --| Returns the contents of the last record of --| the list. L: in List --| The list whose first element is being --| returned. ) return Tree; --| Raises --| EmptyList --| --| Effects --| Returns the last element in a list. If the list is empty EmptyList is --| raised. ------------------------------------------------------------------------------ function Length( --| count the number of elements on a list L: in List --| list whose length is being computed ) return integer; ------------------------------------------------------------------------------ function MakeListIter( --| Sets a variable to point to the head --| of the list. This will be used to --| prepare for iteration over a list. L: in List --| The list being iterated over. ) return ListIter; --| This prepares a user for iteration operation over a list. The iterater is --| an operation which returns successive elements of the list on successive --| calls to the iterator. There needs to be a mechanism which marks the --| position in the list, so on successive calls to the Next operation the --| next item in the list can be returned. This is the function of the --| MakeListIter and the type ListIter. MakeIter just sets the Iter to the --| the beginning of the list. On subsequent calls to NextList the Iter --| is updated with each call. ----------------------------------------------------------------------------- function More( --| Returns true if there are more elements in --| the and false if there aren't any more --| the in the list. L: in ListIter --| List being checked for elements. ) return boolean; ------------------------------------------------------------------------------ procedure Next( --| This is the iterator operation. Given --| a ListIter in the list it returns the --| current item and updates the ListIter. --| If ListIter is at the end of the list, --| More returns false otherwise it --| returns true. Place: in out ListIter; --| The Iter which marks the position in --| the list. Info: out Tree --| The element being returned. ); --| The iterators subprograms MakeListIter, More, and NextList should be used --| in the following way: --| --| L: List; --| Place: ListIter; --| Info: SomeType; --| --| --| Place := MakeListIter(L); --| --| while ( More(Place) ) loop --| NextList(Place, Info); --| process each element of list L; --| end loop; ---------------------------------------------------------------------------- procedure ReplaceHead( --| Replace the Item at the head of the list --| with the parameter Item. L: in out List; --| The list being modified. Info: in Tree --| The information being entered. ); --| Raises --| EmptyList --| Effects --| Replaces the information in the first element in the list. Raises --| EmptyList if the list is empty. ------------------------------------------------------------------------------ procedure ReplaceTail( --| Replace the Tail of a list --| with a new list. L: in out List; --| List whose Tail is replaced. NewTail: in List --| The list which will become the --| tail of Oldlist. ); --| Raises --| EmptyList --| --| Effects --| Replaces the tail of a list with a new list. If the list whose tail --| is being replaced is null EmptyList is raised. ------------------------------------------------------------------------------- function Tail( --| returns the tail of a list L L: in List --| the list whose tail is being returned ) return List; --| Raises --| EmptyList --| --| Effects --| Returns a list which is the tail of the list L. Raises EmptyList if --| L is empty. If L only has one element then Tail returns the Empty --| list. ------------------------------------------------------------------------------ function Equal( --| compares list1 and list2 for equality List1: in List; --| first list List2: in List --| second list ) return boolean; --| Effects --| Returns true if for all elements of List1 the corresponding element --| of List2 has the same value. This function uses the Equal operation --| provided by the user. If one is not provided then = is used. ------------------------------------------------------------------------------ private type Cell; type List is access Cell; --| pointer added by this package --| in order to make a list type Cell is --| Cell for the lists being created record Info: Tree; Next: List; end record; type ListIter is new List; --| This prevents Lists being assigned to --| iterators and vice versa end NodeOrder; type TreeIter is record NodeList :NodeOrder.List; State :NodeOrder.ListIter; end record; end TreePkg; type Set is record SetRep :TreePkg.Tree; end record; type SetIter is record Place :TreePkg.TreeIter; Count :natural; end record; end Literal_Set; -- package Literal_Set is new OrderedSets -- (ItemType => Source_Text.Locator, "<" => "<" ); -- generic -- type ItemType is private; -- with function "<" ( X ,Y: in ItemType) return boolean; type BlockInfoType is record TokenCount :TokenCountType; BlockId :BlockIdType; SetOfLiterals :Literal_Set.Set; SetOfDEF_IDs :DEF_ID_Set.Set; end record; --| This is the information which pertains to a particular block --| of the source program. This information is pushed on --| a stack when an new block is encountered. The --| information is a count of the tokens encountered so far --| and the DEF_ID's which have been found as well as the --| identifying information for the block. The ListOfLiterals --| is a list of all literals encounter --? package BlockInfoStack is new Stacks(BlockInfoType); --? use StackBlockInfo; package BlockInfoStack is type stack is private; --| The stack abstract data type. uninitialized_stack: exception; --| The initialization operations are create and copy. empty_stack: exception; function create return stack; procedure push(s: in out stack; e: BlockInfoType); procedure pop(s: in out stack); procedure pop(s: in out stack; e: out BlockInfoType); function copy(s: stack) return stack; function top(s: stack) return BlockInfoType; function size(s: stack) return natural; function is_empty(s: stack) return boolean; procedure destroy(s: in out stack); private package Lists is type List is private; type ListIter is private; CircularList :exception; --| Raised if an attemp is made to --| create a circular list. This --| results when a list is attempted --| to be attached to itself. EmptyList :exception; --| Raised if an attemp is made to --| manipulate an empty list. ItemNotPresent :exception; --| Raised if an attempt is made to --| remove an element from a list in --| which it does not exist. NoMore :exception; --| Raised if an attemp is made to --| get the next element from a list --| after iteration is complete. procedure Attach( --| appends List2 to List1 List1: in out List; --| The list being appended to. List2: in List --| The list being appended. ); function Attach( --| Creates a new list containing the two --| Elements. Element1: in BlockInfoType; --| This will be first element in list. Element2: in BlockInfoType --| This will be second element in list. ) return List; procedure Attach( --| List L is appended with Element. L: in out List; --| List being appended to. Element: in BlockInfoType --| This will be last element in l ist. ); procedure Attach( --| Makes Element first item in list L. Element: in BlockInfoType; --| This will be the first element in list. L: in out List --| The List which Element is being --| prepended to. ); function Attach ( --| attaches two lists List1: in List; --| first list List2: in List --| second list ) return List; function Attach ( --| prepends an element onto a list Element: in BlockInfoType; --| element being prepended to list L: in List --| List which element is being added --| to ) return List; function Attach ( --| Adds an element to the end of a list L: in List; --| The list which element is being added to. Element: in BlockInfoType --| The element being added to the end of --| the list. ) return List; function Copy( --| returns a copy of list1 L: in List --| list being copied ) return List; function Create --| Returns an empty List return List; procedure DeleteHead( --| Remove the head element from a list. L: in out List --| The list whose head is being removed. ); procedure DeleteItem( --| remove the first occurrence of Element --| from L L: in out List; --| list element is being removed from Element: in BlockInfoType --| element being removed ); procedure DeleteItems( --| remove all occurrences of Element --| from L. L: in out List; --| The List element is being removed from Element: in BlockInfoType --| element being removed ); procedure Destroy( --| removes the list L: in out List --| the list being removed ); function FirstValue( --| returns the contents of the first record of the --| list L: in List --| the list whose first element is being --| returned ) return BlockInfoType; function IsEmpty( --| Checks if a list is empty. L: in List --| List being checked. ) return boolean; function IsInList( --| Checks if element is an element of --| list. L: in List; --| list being scanned for element Element: in BlockInfoType --| element being searched for ) return boolean; function LastValue( --| Returns the contents of the last record of --| the list. L: in List --| The list whose first element is being --| returned. ) return BlockInfoType; function Length( --| count the number of elements on a list L: in List --| list whose length is being computed ) return integer; function MakeListIter( --| Sets a variable to point to the head --| of the list. This will be used to --| prepare for iteration over a list. L: in List --| The list being iterated over. ) return ListIter; function More( --| Returns true if there are more elements in --| the and false if there aren't any more --| the in the list. L: in ListIter --| List being checked for elements. ) return boolean; procedure Next( --| This is the iterator operation. Given --| a ListIter in the list it returns the --| current item and updates the ListIter. --| If ListIter is at the end of the list, --| More returns false otherwise it --| returns true. Place: in out ListIter; --| The Iter which marks the position in --| the list. Info: out BlockInfoType --| The element being returned. ); procedure ReplaceHead( --| Replace the Item at the head of the list --| with the parameter Item. L: in out List; --| The list being modified. Info: in BlockInfoType --| The information being entered. ); procedure ReplaceTail( --| Replace the Tail of a list --| with a new list. L: in out List; --| List whose Tail is replaced. NewTail: in List --| The list which will become the --| tail of Oldlist. ); function Tail( --| returns the tail of a list L L: in List --| the list whose tail is being returned ) return List; function Equal( --| compares list1 and list2 for equality List1: in List; --| first list List2: in List --| second list ) return boolean; private type Cell; type List is access Cell; --| pointer added by this package --| in order to make a list type Cell is --| Cell for the lists being created record Info: BlockInfoType; Next: List; end record; type ListIter is new List; --| This prevents Lists being assigned to --| iterators and vice versa end Lists; subtype elem_list is lists.list; type stack_rec is record size: natural := 0; elts: elem_list; end record; type stack is access stack_rec; end BlockInfoStack; end Definitions; :::::::::::::: ftpme :::::::::::::: :::::::::::::: halstead.ada :::::::::::::: -------SPEC--------------------------------------------------------------- function Halstead return INTEGER; -------BODY--------------------------------------------------------------- with STRING_LISTS; with COMMANDLINE; with STANDARD_INTERFACE; with STRING_PKG; with TEXT_IO; use TEXT_IO; with HOST_LIB; with ST_DIANA; with PROGRAMLIBRARY; with COMP_UNIT_CLASS_PKG; with DEFINITIONS; with HALSTEAD_DATA_BASE; --xx with FILE_MANAGER; function Halstead return INTEGER is package CL renames COMMANDLINE; package SI renames STANDARD_INTERFACE; package SL renames STRING_LISTS; package SP renames STRING_PKG; package D renames DEFINITIONS; package PL renames PROGRAMLIBRARY; package HDB renames HALSTEAD_DATA_BASE; --xx package FM renames FILE_MANAGER; package STRINGTYPE is new SI.STRING_ARGUMENT("string"); package UNIT_LIST_PKG is new SI.STRING_LIST_ARGUMENT( STRING_TYPE_NAME => "string_type", STRING_TYPE_LIST => "string_list"); dd_name : string(1..200); dd_Last : natural; dd_changed : boolean; pl_name : string(1..200); pl_last : natural; HALSTEAD : SI.PROCESS_HANDLE; library_Name : SP.string_type; OUTPUT_FILE: FILE_TYPE; output_File_Name : sp.string_type; unit_list : SL.LIST; ITER : SL.LISTITER; unit_Name : sp.string_type; ToTerminal : boolean; verbose : boolean; Unit_SD : PL.Subdomain_Type; COMP_UNIT_Locator: ST_DIANA.COMP_UNIT_CLASS.Locator; UnitPosition : natural := 1; begin -- driver HOST_LIB.SET_ERROR; SI.set_tool_identifier ("1.0"); STANDARD_INTERFACE.DEFINE_PROCESS(PROC => Halstead, NAME => "Halstead", HELP => "Computes Halstead formulas for Ada compilation units."); UNIT_LIST_PKG.DEFINE_ARGUMENT(PROC => HALSTEAD, NAME => "Units", DEFAULT => SL.CREATE, HELP => "Names of the compilation units"); Stringtype.DEFINE_ARGUMENT(PROC => halstead, NAME => "Output", DEFAULT => "", HELP => "Name of the report file (defaults to standard output)"); STRINGTYPE.DEFINE_ARGUMENT(PROC => HALSTEAD, NAME => "library", DEFAULT => "[.BYRONLIB]", Help => "Name of an Ada program library (NYI)"); SI.DEFINE_PROCESS_HELP(PROC => halstead, HELP => "Computes Halstead formulas for Ada compilation units"); STANDARD_INTERFACE.PARSE_LINE(halstead); unit_list := unit_LIST_pkg.GET_ARGUMENT(PROC => halstead, NAME => "units"); library_Name := stringtype.get_argument(proc => halstead, name => "library"); output_File_Name := STRINGTYPE.GET_ARGUMENT(PROC => halstead, NAME => "output"); verbose := FALSE; if sp.equal(output_File_Name, "") then -- No file name given: output is to the terminal Set_Output(STANDARD_OUTPUT); ToTerminal := true; else -- Create the specified output file create(File => Output_File, Mode => Out_File, Name => sp.value(output_File_Name), Form => "" ); Set_Output(Output_File); ToTerminal := false; end if; -- Connect to the program library directory: --xx FM.Show_and_Set_Default(dd_name,dd_last,dd_changed,SP.Value(library_Name)); --xx if not dd_changed then --xx Put_Line("?? Cannot connect to program library."); --xx return HOST_LIB.RETURN_CODE(HOST_LIB.ERROR); --xx end if; -- Open the catalog. This is the program library which contains -- the library units which the user is performing the Halstead -- Complexity Measures on. PL.Open_catalog; ST_DIANA.NEWDOMAIN (PL.Get_Primary_Context, PL.Get_Secondary_Context); -- Get each library unit which the user is performing the metric on. -- For each unit get its COMP_UNIT_CLASS.Locator which is the handle -- to the beginning of the DIANA for the unit. Pass the Locator -- to the bonsai tree walk routine which computes the metrics. ITER := SL.MAKELISTITER(UNIT_LIST); while SL.MORE(ITER) loop SL.next(iter, unit_Name); -- Check to see if the unit specified is a SubUnit. if cl.IsSubUnit(SP.Value(unit_Name), unitposition) then begin Unit_SD := PL.Open_Subdomain( ST_Diana.TheDomain, PL.DIANA_Form, PL.SubUnit_Ident ( CL.GetParent (sp.value(unit_Name), UnitPosition) , CL.GetSubUnit (sp.value(unit_Name), UnitPosition), IsStub => false )); exception when PL.Object_Not_Up_To_Date => Put(Standard_Output, "%% WARNING: "); Put(Standard_Output, "Subunit " & SP.Value(unit_Name)); Put_Line(Standard_Output, " not found"); end; -- Pass the necessary data to the Utilities package. HDB.InitializeData( LibraryUnit => SP.Value(unit_Name), IsUnitSpec => false, VerboseFlag => Verbose, ToTerminalFlag => ToTerminal, OuterMostBlockFlag => false ); -- If writing to an output file then generate a -- report header. If writing to the terminal a header is -- generated in the utilities package. if not ToTerminal then HDB.ReportHeader (SP.Value(unit_Name), Spec => false); end if; -- Get the actual locator for the library unit. COMP_UNIT_Locator := ST_Diana.Comp_UnitNode.GetRoot (Unit_SD); -- Now that we have the locator scan the diana which -- the locator points to. COMP_UNIT_CLASS_Pkg.Scan_Comp_Unit_Class(COMP_UNIT_Locator); else -- For any library unit which is not a subunit this -- loop scans both the specification (implicit as well -- as explicit) and the body of the unit. for IsSpec in reverse false..true loop -- Open the Subdomain. begin Unit_SD := PL.Open_Subdomain( ST_Diana.TheDomain, PL.DIANA_Form, PL.Library_Unit_Ident ( SP.Value(unit_Name), IsSpec )); -- Pass the data to the utilities package. HDB.InitializeData( LibraryUnit => SP.Value(unit_Name), IsUnitSpec => IsSpec, VerboseFlag => Verbose, ToTerminalFlag => ToTerminal, OuterMostBlockFlag => false ); if not ToTerminal then HDB.ReportHeader (SP.Value(unit_Name), IsSpec); end if; -- Get the locator to the library unit. COMP_UNIT_Locator := ST_Diana.Comp_UnitNode.GetRoot (Unit_SD); -- Perform the scan on the diana which the locator points to. COMP_UNIT_CLASS_Pkg.Scan_Comp_Unit_Class(COMP_UNIT_Locator); -- Catch the exception when attempting to open either -- implicit spec or body. exception when PL.Object_Not_Up_To_Date => Put_Line(Standard_Output, "%% WARNING: "); if IsSpec then Put(Standard_Output, "The spec of "); else Put(Standard_Output, "The body of "); end if; Put(Standard_Output, "Unit " & SP.Value(unit_Name)); Put_Line(Standard_Output, " does not exist"); end; end loop; end if; end loop; --xx FM.Show_and_Set_Default(pl_name, pl_last, dd_changed, dd_name(1..dd_last)); return HOST_LIB.RETURN_CODE(HOST_LIB.SUCCESS); exception when STANDARD_INTERFACE.PROCESS_HELP => return HOST_LIB.RETURN_CODE(HOST_LIB.INFORMATION); when STANDARD_INTERFACE.ABORT_PROCESS => return HOST_LIB.RETURN_CODE(HOST_LIB.ERROR); -- when others => -- TEXT_IO.PUT_LINE("internal error"); -- return HOST_LIB.RETURN_CODE(HOST_LIB.ERROR); end Halstead; :::::::::::::: halstead.obj :::::::::::::: ADA$ELAB_HALSTEAD01 4-Mar-1986 08:55 VAX Ada V1.1-10y< nADA$ELAB_HALSTEAD}>nADA$ELAB_HALSTEADPHALSTEADSTRING_LISTSSTRING_PKG_ STRING_PKGLISTSCOMMANDLINE_COMMANDLINESTANDARD_INTERFACE_STANDARD_INTERFACEINTEGER_LISTSPAGINATED_OUTPUT_PAGINATED_OUTPUTTEXT_IO_TEXT_IOIO_EXCEPTIONS_ HOST_LIB_HOST_LIB ST_DIANA_ST_DIANAML_SOURCE_POSITION_PKG_ML_SOURCE_POSITION_PKGFE_TEMPORARY_ATTRIBUTES_ML_MACHINE_DATA_PKG_TGT_ML_TARGET_CONSTANTS_TGT_ML_TARGET_CONSTANTSML_STORAGE_DIMENSION_PKG_ML_STORAGE_DIMENSION_PKGVMMTEXTPKG_ VMMTEXTPKGVMMSYSTEMPKG_VMMSYSTEMPKGML_VMM_LOCATOR_PKG_VSUTILS_VSUTILSVSDECLARATIONS_VMMBASICPKG_VMMBASICPKGPAGE_IO DIRECT_IOVMMPAGE_HIF_NODE_DEFS_ HIF_DEFS_HIF_FAKE_NODE_HANDLES_HIF_FAKE_NODE_HANDLESHIF_LIST_UTILS_HIF_LIST_UTILSHIF_TEXT_UTILS_HIF_TEXT_UTILSVMMTYPESPKG_VMMTYPESPKGPROGRAMLIBRARY_PROGRAMLIBRARYHIF_HOST_FILE_MANAGEMENT_HIF_HOST_FILE_MANAGEMENTHIF_HOST_FILE_DEFS_PLIF_UTILS_ PLIF_UTILSLIBRARY_CATALOG_DEFS_LIBRARY_COMPILATION_MANAGER_LIBRARY_COMPILATION_MANAGERHIF_NODE_MANAGEMENT_HIF_NODE_MANAGEMENTHIF_SIMPLE_OBJECT_MANAGER_HIF_SIMPLE_OBJECT_MANAGERHIF_RELATIONSHIP_NAMES_HIF_RELATIONSHIP_NAMESHIF_STRINGS_HIF_STRINGSHIF_IDENTIFIERS_HIF_IDENTIFIERSHIF_PARTITION_MANAGER_HIF_PARTITION_MANAGERHIF_PARTITION_ELEMENTS_HIF_PARTITION_ELEMENTSHOST_BIN_KEYED_IO_TYPES_HIF_KEYED_IO_DEFS_RELATIVE_IOAUX_IO_EXCEPTIONS_HIF_PARTITION_MAPPING_HIF_PARTITION_MAPPINGHIF_KEYED_IO_HIF_KEYED_IOBIN_KEYED_IO_BLOCKS_BIN_KEYED_IO_BLOCKSHOST_PAGE_IO_HOST_PAGE_IOBIN_KEYED_IO_UTILITIES_BIN_KEYED_IO_UTILITIESHIF_IDENTIFIER_PATTERNS_HIF_IDENTIFIER_PATTERNSLIBRARY_UNIT_DEFS_LIBRARY_IDENTIFICATION_MANAGER_LIBRARY_IDENTIFICATION_MANAGERLIBRARY_IDENT_MANAGER_LIBRARY_IDENT_MANAGERCOMP_UNIT_CLASS_PKG_COMP_UNIT_CLASS_PKGDEFINITIONS_DEFINITIONSHALSTEAD_DATA_BASE_HALSTEAD_DATA_BASESTRING_UTILITIES_STRING_UTILITIES STACK_PKGSET_PKGADA$U008E7F1B30B92E00_00000097ADA$U008E7F1B30B92E00_0000009AINT_IO CALENDAR_CALENDARSTARLET_CONDITION_HANDLING_CONDITION_HANDLINGT_370_ML_TARGET_CONSTANTS_T_1750A_ML_TARGET_CONSTANTS_T_PRIME_ML_TARGET_CONSTANTS_T_SPERRY_ML_TARGET_CONSTANTS_TGT_ML_TARGET_SWITCH_TGT_ML_TARGET_SWITCH HIF_DEBUG_ HIF_DEBUGPARAMETERS_ PARAMETERSPLIF_DEBUG_ PLIF_DEBUGADA$U008E192A5B0FDC00_00000502LIBRARY_CONFIGURATION_INTERFACELIBRARY_COLLECTION_DEFS_LIBRARY_DEPENDENCY_MANAGER_LIBRARY_DEPENDENCY_MANAGERHIF_NODE_HANDLES_HIF_NODE_HANDLESHOST_SYSTEM_CALLS_HOST_SYSTEM_CALLSHIF_PRS_ATTRIBUTES_HIF_PRS_ATTRIBUTESPLIF_NAME_DEFS_HIF_PATH_NAMES_HIF_PATH_NAMESHIF_ATTRIBUTES_HIF_ATTRIBUTESHIF_KEY_GENERATOR_HIF_KEY_GENERATORHIF_KEYED_IO_LOCALS_HIF_KEYED_IO_LOCALSHIF_RELATIVE_PATHS_PLIF_ATTRIBUTE_NAMES_ ITEM_PKG_ITEM_PKGCOUNT_TYPES_COUNT_TYPESCOUNT_COUNTBOOTOPTIONS_BOOTOPTIONSPLIF_DEPENDENCY_UTILS_PLIF_DEPENDENCY_UTILSHIF_BIG_ATTRIBUTES_HIF_BIG_ATTRIBUTESUP_TO_DATE_CACHE_PKG_UP_TO_DATE_CACHE_PKGHIF_NODE_INFO_DIOSERIES_UNIT_IH_VARIABLE_DECL_IH_SUBTYPE_DECL_IH_TASK_DECL_IH_TYPE_DECL_IH_GENERIC_HEADER_CLASS_PKG_GENERIC_HEADER_CLASS_PKGDEF_ID_PKG_ DEF_ID_PKGPKG_DEF_PKG_PKG_DEF_PKGHEADER_PKG_ HEADER_PKGOBJECT_TYPE_PKG_OBJECT_TYPE_PKGOBJECT_DEF_PKG_OBJECT_DEF_PKGNAME_EXP_PKG_NAME_EXP_PKGCONSTRAINT_PKG_CONSTRAINT_PKGSUBP_DEF_PKG_SUBP_DEF_PKGGENERAL_ASSOC_PKG_GENERAL_ASSOC_PKGBLOCK_STUB_PKG_BLOCK_STUB_PKGTYPE_SPEC_PKG_TYPE_SPEC_PKGGENERIC_HEADER_IH_IDENTIFIER_UTILITIES_IDENTIFIER_UTILITIESAGG_COMPONENT_PKG_AGG_COMPONENT_PKGSTM_PKG_STM_PKGALTERNATIVE_PKG_ALTERNATIVE_PKGBLOCK_STM_IH_SOURCE_POSITION_UTILITIES_SOURCE_POSITION_UTILITIESINNER_RECORD_CLASS_PKG_INNER_RECORD_CLASS_PKGAGG_NAMED_IH_CHOICE_PKG_ CHOICE_PKGITERATION_PKG_ITERATION_PKGBLOCK_UTILITIES_BLOCK_UTILITIESCASE_ALTERNATIVE_IH_HANDLER_ALTERNATIVE_IH_INNER_RECORD_IH_VARIANT_ALTERNATIVE_CLASS_PKG_VARIANT_ALTERNATIVE_CLASS_PKGVMMADDRESSARITHMETIC_VMMADDRESSARITHMETICPLIF_OBJECT_COUNT_UTILS_PLIF_OBJECT_COUNT_UTILS ADA$ELAB_HALSTEAD|{ HALSTEADHALSTEADw/ ]\{ADA$INIT_COMPONENT~P LISTS$ELAB LISTS$ELAB IO_EXCEPTIONS_$ELABIO_EXCEPTIONS_$ELAB ML_SOURCE_POSITION_PKG_$ELABML_SOURCE_POSITION_PKG_$ELAB ML_SOURCE_POSITION_PKG$ELABML_SOURCE_POSITION_PKG$ELAB FE_TEMPORARY_ATTRIBUTES_$ELABFE_TEMPORARY_ATTRIBUTES_$ELAB ML_VMM_LOCATOR_PKG_$ELABML_VMM_LOCATOR_PKG_$ELAB "VSDECLARATIONS_$ELAB"VSDECLARATIONS_$ELAB 'VMMPAGE_$ELAB'VMMPAGE_$ELAB )HIF_DEFS_$ELAB)HIF_DEFS_$ELAB *HIF_FAKE_NODE_HANDLES_$ELAB*HIF_FAKE_NODE_HANDLES_$ELAB +HIF_FAKE_NODE_HANDLES$ELAB+HIF_FAKE_NODE_HANDLES$ELAB BHIF_STRINGS_$ELABBHIF_STRINGS_$ELAB CHIF_STRINGS$ELABCHIF_STRINGS$ELAB MAUX_IO_EXCEPTIONS_$ELABMAUX_IO_EXCEPTIONS_$ELAB iADA$U008E7F1B30B92E00_00000097$iADA$U008E7F1B30B92E00_00000097$ jADA$U008E7F1B30B92E00_0000009A$jADA$U008E7F1B30B92E00_0000009A$ oCONDITION_HANDLING_$ELABoCONDITION_HANDLING_$ELAB pCONDITION_HANDLING$ELABpCONDITION_HANDLING$ELAB qT_370_ML_TARGET_CONSTANTS_$ELABqT_370_ML_TARGET_CONSTANTS_$ELAB rT_1750A_ML_TARGET_CONSTANTS_$ELrT_1750A_ML_TARGET_CONSTANTS_$EL sT_PRIME_ML_TARGET_CONSTANTS_$ELsT_PRIME_ML_TARGET_CONSTANTS_$EL tT_SPERRY_ML_TARGET_CONSTANTS_$EtT_SPERRY_ML_TARGET_CONSTANTS_$E HIF_KEY_GENERATOR_$ELABHIF_KEY_GENERATOR_$ELAB HIF_KEY_GENERATOR$ELABHIF_KEY_GENERATOR$ELAB gSTACK_PKG$ELABgSTACK_PKG$ELAB INTEGER_LISTS$ELAB INTEGER_LISTS$ELAB hSET_PKG$ELABhSET_PKG$ELAB &DIRECT_IO$ELAB&DIRECT_IO$ELAB TEXT_IO_$ELABTEXT_IO_$ELAB TEXT_IO$ELABTEXT_IO$ELAB JSOURCE_POSITION_UTILITIES_$ELABJSOURCE_POSITION_UTILITIES_$ELAB KSOURCE_POSITION_UTILITIES$ELABKSOURCE_POSITION_UTILITIES$ELAB ZVMMADDRESSARITHMETIC_$ELABZVMMADDRESSARITHMETIC_$ELAB [VMMADDRESSARITHMETIC$ELAB[VMMADDRESSARITHMETIC$ELAB KHIF_KEYED_IO_DEFS_$ELABKHIF_KEYED_IO_DEFS_$ELAB 6HIF_HOST_FILE_DEFS_$ELAB6HIF_HOST_FILE_DEFS_$ELAB (HIF_NODE_DEFS_$ELAB(HIF_NODE_DEFS_$ELAB DHIF_IDENTIFIERS_$ELABDHIF_IDENTIFIERS_$ELAB EHIF_IDENTIFIERS$ELABEHIF_IDENTIFIERS$ELAB LRELATIVE_IO$ELABLRELATIVE_IO$ELAB nSTARLET_$ELABnSTARLET_$ELAB STRING_PKG_$ELABSTRING_PKG_$ELAB STRING_PKG$ELABSTRING_PKG$ELAB "DIO$ELAB"DIO$ELAB %PAGE_IO$ELAB%PAGE_IO$ELAB kINT_IO$ELABkINT_IO$ELAB .HIF_TEXT_UTILS_$ELAB.HIF_TEXT_UTILS_$ELAB /HIF_TEXT_UTILS$ELAB/HIF_TEXT_UTILS$ELAB VMMTEXTPKG_$ELABVMMTEXTPKG_$ELAB VMMTEXTPKG$ELABVMMTEXTPKG$ELAB PLIF_ATTRIBUTE_NAMES_$ELABPLIF_ATTRIBUTE_NAMES_$ELAB PLIF_NAME_DEFS_$ELABPLIF_NAME_DEFS_$ELAB XHIF_IDENTIFIER_PATTERNS_$ELABXHIF_IDENTIFIER_PATTERNS_$ELAB YHIF_IDENTIFIER_PATTERNS$ELABYHIF_IDENTIFIER_PATTERNS$ELAB @HIF_RELATIONSHIP_NAMES_$ELAB@HIF_RELATIONSHIP_NAMES_$ELAB AHIF_RELATIONSHIP_NAMES$ELABAHIF_RELATIONSHIP_NAMES$ELAB JHOST_BIN_KEYED_IO_TYPES_$ELABJHOST_BIN_KEYED_IO_TYPES_$ELAB lCALENDAR_$ELABlCALENDAR_$ELAB mCALENDAR$ELABmCALENDAR$ELAB STRING_LISTS$ELABSTRING_LISTS$ELAB COMMANDLINE_$ELABCOMMANDLINE_$ELAB COMMANDLINE$ELABCOMMANDLINE$ELAB BOOTOPTIONS_$ELABBOOTOPTIONS_$ELAB BOOTOPTIONS$ELABBOOTOPTIONS$ELAB ZLIBRARY_UNIT_DEFS_$ELABZLIBRARY_UNIT_DEFS_$ELAB VSUTILS_$ELAB VSUTILS_$ELAB !VSUTILS$ELAB!VSUTILS$ELAB eSTRING_UTILITIES_$ELABeSTRING_UTILITIES_$ELAB fSTRING_UTILITIES$ELABfSTRING_UTILITIES$ELAB HOST_SYSTEM_CALLS_$ELABHOST_SYSTEM_CALLS_$ELAB HOST_SYSTEM_CALLS$ELABHOST_SYSTEM_CALLS$ELAB yPARAMETERS_$ELAByPARAMETERS_$ELAB zPARAMETERS$ELABzPARAMETERS$ELAB VMMSYSTEMPKG_$ELABVMMSYSTEMPKG_$ELAB VMMSYSTEMPKG$ELABVMMSYSTEMPKG$ELAB HOST_LIB_$ELABHOST_LIB_$ELAB HOST_LIB$ELABHOST_LIB$ELAB PAGINATED_OUTPUT_$ELAB PAGINATED_OUTPUT_$ELAB PAGINATED_OUTPUT$ELABPAGINATED_OUTPUT$ELAB {PLIF_DEBUG_$ELAB{PLIF_DEBUG_$ELAB |PLIF_DEBUG$ELAB|PLIF_DEBUG$ELAB wHIF_DEBUG_$ELABwHIF_DEBUG_$ELAB xHIF_DEBUG$ELABxHIF_DEBUG$ELAB uTGT_ML_TARGET_SWITCH_$ELABuTGT_ML_TARGET_SWITCH_$ELAB vTGT_ML_TARGET_SWITCH$ELABvTGT_ML_TARGET_SWITCH$ELAB STANDARD_INTERFACE_$ELABSTANDARD_INTERFACE_$ELAB STANDARD_INTERFACE$ELABSTANDARD_INTERFACE$ELAB ]LIBRARY_IDENT_MANAGER_$ELAB]LIBRARY_IDENT_MANAGER_$ELAB ^LIBRARY_IDENT_MANAGER$ELAB^LIBRARY_IDENT_MANAGER$ELAB THOST_PAGE_IO_$ELABTHOST_PAGE_IO_$ELAB UHOST_PAGE_IO$ELABUHOST_PAGE_IO$ELAB HIF_PATH_NAMES_$ELAB HIF_PATH_NAMES_$ELAB HIF_PATH_NAMES$ELAB HIF_PATH_NAMES$ELAB HHIF_PARTITION_ELEMENTS_$ELABHHIF_PARTITION_ELEMENTS_$ELAB IHIF_PARTITION_ELEMENTS$ELABIHIF_PARTITION_ELEMENTS$ELAB ,HIF_LIST_UTILS_$ELAB,HIF_LIST_UTILS_$ELAB -HIF_LIST_UTILS$ELAB-HIF_LIST_UTILS$ELAB TGT_ML_TARGET_CONSTANTS_$ELABTGT_ML_TARGET_CONSTANTS_$ELAB TGT_ML_TARGET_CONSTANTS$ELABTGT_ML_TARGET_CONSTANTS$ELAB RBIN_KEYED_IO_BLOCKS_$ELABRBIN_KEYED_IO_BLOCKS_$ELAB SBIN_KEYED_IO_BLOCKS$ELABSBIN_KEYED_IO_BLOCKS$ELAB LIBRARY_COLLECTION_DEFS_$ELABLIBRARY_COLLECTION_DEFS_$ELAB 9LIBRARY_CATALOG_DEFS_$ELAB9LIBRARY_CATALOG_DEFS_$ELAB ML_STORAGE_DIMENSION_PKG_$ELABML_STORAGE_DIMENSION_PKG_$ELAB ML_STORAGE_DIMENSION_PKG$ELABML_STORAGE_DIMENSION_PKG$ELAB ML_MACHINE_DATA_PKG_$ELABML_MACHINE_DATA_PKG_$ELAB VBIN_KEYED_IO_UTILITIES_$ELABVBIN_KEYED_IO_UTILITIES_$ELAB WBIN_KEYED_IO_UTILITIES$ELABWBIN_KEYED_IO_UTILITIES$ELAB HIF_KEYED_IO_LOCALS_$ELABHIF_KEYED_IO_LOCALS_$ELAB HIF_KEYED_IO_LOCALS$ELABHIF_KEYED_IO_LOCALS$ELAB PHIF_KEYED_IO_$ELABPHIF_KEYED_IO_$ELAB QHIF_KEYED_IO$ELABQHIF_KEYED_IO$ELAB NHIF_PARTITION_MAPPING_$ELABNHIF_PARTITION_MAPPING_$ELAB OHIF_PARTITION_MAPPING$ELABOHIF_PARTITION_MAPPING$ELAB FHIF_PARTITION_MANAGER_$ELABFHIF_PARTITION_MANAGER_$ELAB GHIF_PARTITION_MANAGER$ELABGHIF_PARTITION_MANAGER$ELAB >HIF_SIMPLE_OBJECT_MANAGER_$ELAB>HIF_SIMPLE_OBJECT_MANAGER_$ELAB ?HIF_SIMPLE_OBJECT_MANAGER$ELAB?HIF_SIMPLE_OBJECT_MANAGER$ELAB !HIF_NODE_INFO_$ELAB!HIF_NODE_INFO_$ELAB HIF_PRS_ATTRIBUTES_$ELABHIF_PRS_ATTRIBUTES_$ELAB HIF_PRS_ATTRIBUTES$ELABHIF_PRS_ATTRIBUTES$ELAB HIF_NODE_HANDLES_$ELABHIF_NODE_HANDLES_$ELAB HIF_NODE_HANDLES$ELABHIF_NODE_HANDLES$ELAB #VMMBASICPKG_$ELAB#VMMBASICPKG_$ELAB 4HIF_HOST_FILE_MANAGEMENT_$ELAB4HIF_HOST_FILE_MANAGEMENT_$ELAB 7PLIF_UTILS_$ELAB7PLIF_UTILS_$ELAB <HIF_NODE_MANAGEMENT_$ELAB<HIF_NODE_MANAGEMENT_$ELAB HIF_ATTRIBUTES_$ELABHIF_ATTRIBUTES_$ELAB PLIF_DEPENDENCY_UTILS_$ELABPLIF_DEPENDENCY_UTILS_$ELAB HIF_BIG_ATTRIBUTES_$ELABHIF_BIG_ATTRIBUTES_$ELAB UP_TO_DATE_CACHE_PKG_$ELABUP_TO_DATE_CACHE_PKG_$ELAB 0VMMTYPESPKG_$ELAB0VMMTYPESPKG_$ELAB 1VMMTYPESPKG$ELAB1VMMTYPESPKG$ELAB HIF_RELATIVE_PATHS_$ELABHIF_RELATIVE_PATHS_$ELAB :LIBRARY_COMPILATION_MANAGER_$EL:LIBRARY_COMPILATION_MANAGER_$EL ;LIBRARY_COMPILATION_MANAGER$ELA;LIBRARY_COMPILATION_MANAGER$ELA 8PLIF_UTILS$ELAB8PLIF_UTILS$ELAB 5HIF_HOST_FILE_MANAGEMENT$ELAB5HIF_HOST_FILE_MANAGEMENT$ELAB \PLIF_OBJECT_COUNT_UTILS_$ELAB\PLIF_OBJECT_COUNT_UTILS_$ELAB ]PLIF_OBJECT_COUNT_UTILS$ELAB]PLIF_OBJECT_COUNT_UTILS$ELAB $VMMBASICPKG$ELAB$VMMBASICPKG$ELAB }ADA$U008E192A5B0FDC00_00000502$}ADA$U008E192A5B0FDC00_00000502$ ~LIBRARY_CONFIGURATION_INTERFACE~LIBRARY_CONFIGURATION_INTERFACE =HIF_NODE_MANAGEMENT$ELAB=HIF_NODE_MANAGEMENT$ELAB HIF_ATTRIBUTES$ELABHIF_ATTRIBUTES$ELAB PLIF_DEPENDENCY_UTILS$ELABPLIF_DEPENDENCY_UTILS$ELAB HIF_BIG_ATTRIBUTES$ELABHIF_BIG_ATTRIBUTES$ELAB UP_TO_DATE_CACHE_PKG$ELAB UP_TO_DATE_CACHE_PKG$ELAB ST_DIANA_$ELABST_DIANA_$ELAB ST_DIANA$ELABST_DIANA$ELAB WINNER_RECORD_IH_$ELABWINNER_RECORD_IH_$ELAB VHANDLER_ALTERNATIVE_IH_$ELABVHANDLER_ALTERNATIVE_IH_$ELAB UCASE_ALTERNATIVE_IH_$ELABUCASE_ALTERNATIVE_IH_$ELAB SBLOCK_UTILITIES_$ELABSBLOCK_UTILITIES_$ELAB TBLOCK_UTILITIES$ELABTBLOCK_UTILITIES$ELAB NAGG_NAMED_IH_$ELABNAGG_NAMED_IH_$ELAB IBLOCK_STM_IH_$ELABIBLOCK_STM_IH_$ELAB AIDENTIFIER_UTILITIES_$ELABAIDENTIFIER_UTILITIES_$ELAB BIDENTIFIER_UTILITIES$ELABBIDENTIFIER_UTILITIES$ELAB @GENERIC_HEADER_IH_$ELAB@GENERIC_HEADER_IH_$ELAB 'TYPE_DECL_IH_$ELAB'TYPE_DECL_IH_$ELAB &TASK_DECL_IH_$ELAB&TASK_DECL_IH_$ELAB %SUBTYPE_DECL_IH_$ELAB%SUBTYPE_DECL_IH_$ELAB $VARIABLE_DECL_IH_$ELAB$VARIABLE_DECL_IH_$ELAB #SERIES_UNIT_IH_$ELAB#SERIES_UNIT_IH_$ELAB aDEFINITIONS_$ELABaDEFINITIONS_$ELAB bDEFINITIONS$ELABbDEFINITIONS$ELAB COUNT_TYPES_$ELABCOUNT_TYPES_$ELAB COUNT_TYPES$ELABCOUNT_TYPES$ELAB COUNT_$ELABCOUNT_$ELAB COUNT$ELAB COUNT$ELAB cHALSTEAD_DATA_BASE_$ELABcHALSTEAD_DATA_BASE_$ELAB dHALSTEAD_DATA_BASE$ELABdHALSTEAD_DATA_BASE$ELAB *DEF_ID_PKG_$ELAB*DEF_ID_PKG_$ELAB +DEF_ID_PKG$ELAB+DEF_ID_PKG$ELAB [LIBRARY_IDENTIFICATION_MANAGER_[LIBRARY_IDENTIFICATION_MANAGER_ _COMP_UNIT_CLASS_PKG_$ELAB_COMP_UNIT_CLASS_PKG_$ELAB LIBRARY_DEPENDENCY_MANAGER_$ELALIBRARY_DEPENDENCY_MANAGER_$ELA ITEM_PKG_$ELABITEM_PKG_$ELAB (GENERIC_HEADER_CLASS_PKG_$ELAB(GENERIC_HEADER_CLASS_PKG_$ELAB ,PKG_DEF_PKG_$ELAB,PKG_DEF_PKG_$ELAB .HEADER_PKG_$ELAB.HEADER_PKG_$ELAB 0OBJECT_TYPE_PKG_$ELAB0OBJECT_TYPE_PKG_$ELAB 2OBJECT_DEF_PKG_$ELAB2OBJECT_DEF_PKG_$ELAB 4NAME_EXP_PKG_$ELAB4NAME_EXP_PKG_$ELAB 6CONSTRAINT_PKG_$ELAB6CONSTRAINT_PKG_$ELAB 8SUBP_DEF_PKG_$ELAB8SUBP_DEF_PKG_$ELAB :GENERAL_ASSOC_PKG_$ELAB:GENERAL_ASSOC_PKG_$ELAB <BLOCK_STUB_PKG_$ELAB<BLOCK_STUB_PKG_$ELAB >TYPE_SPEC_PKG_$ELAB>TYPE_SPEC_PKG_$ELAB CAGG_COMPONENT_PKG_$ELABCAGG_COMPONENT_PKG_$ELAB ESTM_PKG_$ELABESTM_PKG_$ELAB GALTERNATIVE_PKG_$ELABGALTERNATIVE_PKG_$ELAB LINNER_RECORD_CLASS_PKG_$ELABLINNER_RECORD_CLASS_PKG_$ELAB OCHOICE_PKG_$ELABOCHOICE_PKG_$ELAB QITERATION_PKG_$ELABQITERATION_PKG_$ELAB XVARIANT_ALTERNATIVE_CLASS_PKG_$XVARIANT_ALTERNATIVE_CLASS_PKG_$ \LIBRARY_IDENTIFICATION_MANAGER$\LIBRARY_IDENTIFICATION_MANAGER$ 2PROGRAMLIBRARY_$ELAB2PROGRAMLIBRARY_$ELAB 3PROGRAMLIBRARY$ELAB3PROGRAMLIBRARY$ELAB LIBRARY_DEPENDENCY_MANAGER$ELABLIBRARY_DEPENDENCY_MANAGER$ELAB `COMP_UNIT_CLASS_PKG$ELAB`COMP_UNIT_CLASS_PKG$ELAB )GENERIC_HEADER_CLASS_PKG$ELAB)GENERIC_HEADER_CLASS_PKG$ELAB 3OBJECT_DEF_PKG$ELAB3OBJECT_DEF_PKG$ELAB /HEADER_PKG$ELAB/HEADER_PKG$ELAB ;GENERAL_ASSOC_PKG$ELAB;GENERAL_ASSOC_PKG$ELAB 9SUBP_DEF_PKG$ELAB9SUBP_DEF_PKG$ELAB -PKG_DEF_PKG$ELAB-PKG_DEF_PKG$ELAB 1OBJECT_TYPE_PKG$ELAB1OBJECT_TYPE_PKG$ELAB ITEM_PKG$ELABITEM_PKG$ELAB 7CONSTRAINT_PKG$ELAB7CONSTRAINT_PKG$ELAB 5NAME_EXP_PKG$ELAB5NAME_EXP_PKG$ELAB =BLOCK_STUB_PKG$ELAB=BLOCK_STUB_PKG$ELAB ?TYPE_SPEC_PKG$ELAB?TYPE_SPEC_PKG$ELAB HALTERNATIVE_PKG$ELABHALTERNATIVE_PKG$ELAB DAGG_COMPONENT_PKG$ELABDAGG_COMPONENT_PKG$ELAB PCHOICE_PKG$ELABPCHOICE_PKG$ELAB FSTM_PKG$ELABFSTM_PKG$ELAB RITERATION_PKG$ELABRITERATION_PKG$ELAB MINNER_RECORD_CLASS_PKG$ELABMINNER_RECORD_CLASS_PKG$ELAB YVARIANT_ALTERNATIVE_CLASS_PKG$EYVARIANT_ALTERNATIVE_CLASS_PKG$E HALSTEAD$ELABHALSTEAD$ELABADA$INIT_COMPONENTLIB$INITIALIZEi$CODE|LIB$INITIALIZE} HALSTEADHALSTEADoTRANSFER$ADDRESSw?=:::::::::::::: hdb.bdy :::::::::::::: with Count_Types; with Count; with Text_IO; use Text_IO; with Int_IO; use Int_IO; with VmmTextPkg; with Unchecked_Deallocation; package body Halstead_Data_Base is --| OVERVIEW --| This package does all the counting and processing of the information --| for a block. It analyzes all the token information and determines --| the number of unique operators and operands for the block. It --| scans the list of DEF_ID's in the block and determines whether --| each DEF_ID is either an operator or operand. It also scans the --| list of literals and determines the number of different literals --| as well as the number of times each literal on the list has been --| used. The literals are all counted asoperands. --| --| Using the number of unique operands and operators all the Halstead --| Metrics are computed. The metrics are then displayed using the --| procedure PrintInfo. -------------------------------------------------------------------------- -- LOCAL OBJECTS -------------------------------------------------------------------------- package C renames Count; package CT renames Count_Types; BlockKindLength :constant := 9; MaxLineLength :constant := 80; NumberOfMetrics :constant := 17; NumberOfLinesToClearScreen :constant := 8; BlockStrings: array(BlockKind) of string(1..BlockKindLength) := ( "PROCEDURE", "FUNCTION ", "PACKAGE ", "PACKAGE ", "TASK ", "TASK ", -- The following string is used for declare blocks. It is blank -- because of the DecId string in pkg Definitions. " "); --| These are the strings which will be printed out in the output --| for the corresponding block type. StroudNumber :integer range 5..20 := 5; --| This number is used as a constant in the metric calculations. E0 :integer := 3000; --| Number of elementary discriminations between errors. type Real is digits 6; type MetricsRecord is record UniqueOperators :Float; UniqueOperands :Float; Vocabulary :Float; OperatorUsage :Float; OperandUsage :Float; ProgramLength :Float; EstimatedProgramLength :Float; ProgramVolume :Float; PotentialVolume :Float; ProgramLevel :Float; ProgramLevelApprox :Float; IntelligenceContent :Float; ProgrammingEffort :Float; ProgrammingTime :Float; LanguageLevel :Float; NumberOfDeliveredErrors :Float; ApproxNumberOfDeliveredErrors :Float; end record; --| Each field of this record corresponds to one of the 17 --| Halstead metrics. -------------------------------------------------------------------------- -- LOCAL SUBPROGRAMS -------------------------------------------------------------------------- -------------------------------------------------------------------------- procedure Free is new Unchecked_Deallocation (String, StringPtr); -------------------------------------------------------------------------- function SymRepToString ( --| Converts a SymRep to a string SymRep :in symbol_repNode.Locator ) return String is begin if symbol_repNode.IsNull (SymRep) then return ""; else return VmmTextPkg.Value ( Source_Text.Value ( lx_text ( ne_normalized_symrep ( ne_symbol_entry_in_table ( SymRep))))); end if; end SymRepToString; -------------------------------------------------------------------------- function TruncateSymrep( symrep : symbol_repNode.Locator; length : natural ) return string is TempName : String(1 .. length) := (others => ' '); begin if TOKEN.IsNull (symrep) then return TempName; else declare FullName : constant String :=SymRepToString (symrep); size : constant Integer := FullName'length; begin if size < length then TempName(1 .. Size) := FullName(1 .. Size); else TempName := FullName(1 .. length); end if; return TempName; end; end if; end TruncateSymrep; --------------------------------------------------------------------- ---- procedure DEF_ID_Analysis ( -- This procedure counts and analyzes -- all the identifiers in the program as -- either operands or operators. SetOfDEF_IDs :in DEF_ID_Set.Set; Nn :in out CT.NnInfoType; N2Star :in out natural ) is Place :DEF_ID_Set.SetIter; Member :DEF_ID.Locator; package DIS renames DEF_ID_Set; begin --| OVERVIEW --| Walk over the SetOfDEF_IDs. Each member in the set increments --| its class's Vocabulary by 1 and its class's Usage by the --| Countof the member. The Kind of each member determines --| which class it is in either an operator, an operand or --| neither. --| --| Calculate N2Star by counting the number of parameters to --| the program unit. Place := DIS.MakeSetIter (SetOfDEF_IDs); while DIS.More (Place) loop DIS.Next (Place, Member); case Kind (Member) is when ATTRIBUTE_IDKind | BUILT_IN_OPERATORKind | GENERAL_TYPE_IDKind | pkg_idKind | PRAGMA_IDKind | STM_IDKind | SUBP_IDKind | subtype_idKind | task_body_idKind => Nn(operator).Vocabulary := Nn(operator).Vocabulary + 1; Nn(operator).Usage := Nn(operator).Usage + DIS.GetCount (Place); if VerboseOn then Put (Standard_Output, "number of uses of "); Put (Standard_Output, SymRepToString (lx_symrep (Member))); Put (Standard_Output, " "); Put (Standard_Output, AnyKind 'image (Kind (Member))); Put (Standard_Output, " equals "); Put (Standard_Output, DIS.GetCount (Place)); Put (Standard_Output, " operators "); New_Line(Standard_Output); end if; when LITERAL_IDKind | OBJECT_IDKind| argument_idKind | exception_idKind | iteration_id | number_idKind => Nn(operand).Vocabulary := Nn(operand).Vocabulary + 1; Nn(operand).Usage := Nn(operand).Usage + DIS.GetCount (Place); if Kind (Member) in Param_idKind then N2Star := N2Star + 1; end if; if VerboseOn then Put (Standard_Output, "number of uses of "); Put (Standard_Output, SymRepToString (lx_symrep (Member))); Put (Standard_Output, " which is a "); Put (Standard_Output, AnyKind 'image (Kind (Member))); Put (Standard_Output, " equals "); Put (Standard_Output, DIS.GetCount (Place)); Put (Standard_Output, " operands "); New_Line (Standard_Output); end if; when others => null; end case; end loop; end DEF_ID_Analysis; -------------------------------------------------------------------------- procedure Literal_Analysis ( SetOfLiterals :in Literal_Set.Set; Nn :in out CT.NnInfoType ) is I :Literal_Set.SetIter; Member :Source_Text.Locator; package LS renames Literal_Set; begin --| OVERVIEW --| Walk over SetOfLiterals. Each member in the set increments --| the Vocabulary of the operands by one. The count of each --| member in the set increments the Usage of operands by the --| count. I := LS.MakeSetIter (SetOfLiterals); Nn(operand).Vocabulary := Nn(operand).Vocabulary + LS.Cardinality (SetOfLiterals); while LS.More (I) loop LS.Next (I, Member); Nn(operand).Usage := Nn(operand).Usage + LS.GetCount (I); if VerboseOn then Put (Standard_Output, "the literal "); Put (Standard_Output, VmmTextPkg.Value (Source_Text.Value (Member))); Put (Standard_Output, " appears "); Put (Standard_Output, LS.GetCount(I)); Put (Standard_Output, " times "); New_Line(Standard_Output); end if; end loop; end Literal_Analysis; -------------------------------------------------------------------------- function SeriesValue ( --| This function computes the ln (1 + x). X :in Float ) return Float is N :integer := 6; SumOfSeries :Float; Fraction :Float; LnOfTwo :Float; begin --| OVERVIEW --| --| The series for ln (1 + X) = --| --| x - x**2/2 + x**3/3 - x**4/4 + x**5/5 .... --| --| This is being factored inorder to save computations to be --| --| x ( 1 + x(-1/2 + x(1/3 + x(-1/4 ..... --| --| This is being computed from inside out. LnOfTwo := 6931.0/10000.0; SumOfSeries := 0.0; for i in reverse 1..N loop Fraction := 1.0/Float(i); if (i mod 2) = 0 then SumOfSeries := SumOfSeries - Fraction; else SumOfSeries := SumOfSeries + Fraction; end if; SumOfSeries := SumOfSeries * X; end loop; SumOfSeries := SumOfSeries / LnOfTwo; return SumOfSeries; end SeriesValue; -------------------------------------------------------------------------- function Log2 ( X :in Float ) return Float is U_X :Float; IntegerPart :Float; LogForFraction :Float; LowerBound :Float; X_For_Series :Float; InputOutOfBounds :exception; --| This computes the log2(X) by using the following method. --| --| First get the integer part of the log by testing when 2**n is --| greater than X. The integer part of log2(X) is then n - 1. --| --| Then we calculate the fraction part of log2(x) by using the --| expression --| --| ln(1 + x) = x - x**2/2 + x**3/3 - x**4/4 ..... --| --| Then by using the fact log2(x) = ln(X)/ln(2) we have log2(X). --| --| For example if x = 70 --| --| log2 (70) = log2 (64 * 70/64) = 6 + log2(70/64) --| --| log2( 70/64 )= log2( 1 + 6/64) = ln(1 + 6/64) / ln(2) --| --| log2 (1 + 64/70) is calculated by the function SeriesValue --| when passed (64/70). begin if X < 0.0 then raise InputOutOfBounds; else U_X := Float(Integer(X)); LowerBound := 1.0; IntegerPart := 0.0; while 2.0 * LowerBound <= U_X loop IntegerPart := IntegerPart + 1.0; LowerBound := LowerBound * 2.0; end loop; if LowerBound = U_X then return IntegerPart; else -- Following the example above at this point we compute -- log2 (70/64) = log2 (1 + 6/64) -- log2 (1 + 6/64) = SeriesValue (6/64). -- U_X - LowerBound is in the example 70 - 64. Therefore -- (U_X - LowerBound) / LowerBound is 6/64. X_For_Series := (U_X - LowerBound)/LowerBound; LogForFraction := SeriesValue(X_For_Series); return IntegerPart + LogForFraction; end if; end if; end Log2; -------------------------------------------------------------------------- function Exp ( --| Raises the natural log e to the power X. X :in Float ) return Float is NumberOfIterations :integer := 6; --| Number of Iterations used to calculate --| series. Series :Float; Factorial :Float; begin Series := 1.0; Factorial := 1.0; for i in 1..NumberOfIterations loop -- Caculate Factorial Factorial := Factorial * Float(i); Series := Series + ((X ** i) / Factorial); end loop; return Series; end Exp; -------------------------------------------------------------------------- function TwoThirdsPower ( --| Calculates X ** (2/3) by finding a --| a Y such that X ** 2 = Y ** 3 X :in Float ) return Float is Y :float := 1.0; SquareX :float; CubeY :float; CubeDelta :float; begin --| OVERVIEW --| Y = x ** (2/3) -> --| Y**3 = X**2 --| --| This function computes Y such that --| Y**3 <= X**2 is true. SquareX := X ** 2; CubeY := Y ** 3; CubeDelta := CubeY + ((3.0 * Y) * (Y + 1.0)) + 1.0; -- The following shows how to incremently compute (Y+1)**3 when -- Y **3 exists. -- -- ((Y + 1) ** 3) - (Y**3) = -- Y**3 + 3Y**2 + 3Y + 1 - Y**3 = -- 3Y**2 + 3Y + 1 = -- 3Y(Y + 1) + 1 while CubeY + CubeDelta < SquareX loop Y := Y + 1.0; CubeDelta := ((3.0 * Y) * (Y + 1.0)) + 1.0; end loop; return Y; end TwoThirdsPower; -------------------------------------------------------------------------- procedure CalcEstimatedProgramLength ( --| Computes the estimated program length --| given the number of unique operators --| and operands. N1 :in Float; --| number of unique operators N2 :in Float; --| number of unique operands Result :in out Float ) is begin Result := (N1 * log2(N1)) + (N2 * log2(N2)); end CalcEstimatedProgramLength; -------------------------------------------------------------------------- procedure CalcProgramVolume ( --| Computes the program volume --| given the vocabulary. ProgramLength :in Float; Vocabulary :in Float; Result :in out Float ) is begin Result := ProgramLength * log2(Vocabulary); end CalcProgramVolume; -------------------------------------------------------------------------- procedure CalcPotentialVolume( N2Star :in natural; --| minimum number of input output --| parameters. Result :in out Float ) is begin Result := (2.0 + Float(N2Star)) * log2(2.0 + Float(N2Star)); end CalcPotentialVolume; -------------------------------------------------------------------------- procedure CalcProgramLevel ( VStar :in Float; V :in Float; Result :in out Float ) is begin Result := VStar / V; exception when Numeric_Error => -- This catches the case when the denominator is 0. Result := 0.0; end CalcProgramLevel; -------------------------------------------------------------------------- procedure CalcProgramLevelApprox( --| minimum number of operators, --| number of unique operators, --| number of unique operands --| and total number of operands. N1 :in Float; N2Unique :in Float; N2Total :in Float; N1Star :in natural := 2; --| Minimum number of operators --| necessary Result :in out Float ) is begin Result := Float(N1Star)/N1 * N2Unique * N2Total; exception when Numeric_Error => -- This catches the case when the denominator is 0. Result := 0.0; end CalcProgramLevelApprox; -------------------------------------------------------------------------- procedure CalcIntelligenceContent ( L_Approx :in Float; V :in Float; Result :in out Float ) is begin Result := L_Approx * V; end CalcIntelligenceContent; -------------------------------------------------------------------------- procedure CalcProgrammingEffort ( V :in Float; L :in Float; Result :in out Float ) is begin Result := V / L; exception when Numeric_Error => -- This catches the case when the denominator is 0. Result := 0.0; end CalcProgrammingEffort; -------------------------------------------------------------------------- procedure CalcProgrammingTime ( E :in Float; S :in natural; --| Stroud number. Result :in out Float ) is begin Result := E/Float(S); end CalcProgrammingTime; -------------------------------------------------------------------------- procedure CalcLanguageLevel ( L :in Float; VStar :in Float; Result :in out Float ) is begin Result := L * VStar; end CalcLanguageLevel; -------------------------------------------------------------------------- procedure CalcNumberOfDeliveredErrors ( E :in Float; E0 :in natural; Result :in out Float ) is begin -- E**(2/3) / E0 Result := TwoThirdsPower(E) / Float(E0); end CalcNumberOfDeliveredErrors; -------------------------------------------------------------------------- procedure CalcApproxNumberOfDeliveredErrors ( V :in Float; E0 :in natural; Result :in out Float ) is begin Result := V / Float(E0); end CalcApproxNumberOfDeliveredErrors; -------------------------------------------------------------------------- procedure MetricCalculations ( Nn :in CT.NnInfoType; N2Star :in natural; Metrics :in out MetricsRecord ) is begin Metrics.UniqueOperators := Float(Nn(operator).Vocabulary); Metrics.UniqueOperands := Float(Nn(operand).Vocabulary); Metrics.OperandUsage := Float(Nn(operand).Usage); Metrics.OperatorUsage := Float(Nn(operator).Usage); Metrics.Vocabulary := Metrics.UniqueOperators + Metrics.UniqueOperands; Metrics.ProgramLength := Metrics.OperandUsage + Metrics.OperatorUsage; CalcEstimatedProgramLength(Metrics.UniqueOperators, Metrics.UniqueOperands, Metrics.EstimatedProgramLength); CalcProgramVolume(Metrics.ProgramLength, Metrics.Vocabulary, Metrics.ProgramVolume); CalcPotentialVolume(N2Star, Metrics.PotentialVolume); CalcProgramLevel(Metrics.PotentialVolume, Metrics.ProgramVolume, Metrics.ProgramLevel); CalcProgramLevelApprox(Metrics.UniqueOperators, Metrics.UniqueOperands, Metrics.OperandUsage, Result => Metrics.ProgramLevelApprox); CalcIntelligenceContent(Metrics.ProgramLevelApprox, Metrics.ProgramVolume, Metrics.IntelligenceContent); CalcProgrammingEffort(Metrics.ProgramVolume, Metrics.ProgramLevel, Metrics.ProgrammingEffort); CalcProgrammingTime(Metrics.ProgrammingEffort, StroudNumber, Metrics.ProgrammingTime); CalcLanguageLevel(Metrics.ProgramLevel, Metrics.PotentialVolume, Metrics.LanguageLevel); CalcNumberOfDeliveredErrors(Metrics.ProgrammingEffort, E0, Metrics.NumberOfDeliveredErrors); CalcApproxNumberOfDeliveredErrors( Metrics.ProgramVolume, E0, Metrics.ApproxNumberOfDeliveredErrors); end MetricCalculations; ------------------------------------------------------------------------- function Center ( --|This centers the string S in a buffer of blanks --|whose width is Width. S :in String; Width :in positive ) return String is Result :String(1..Width) := (others => ' '); Start :positive; Finish :positive; BufferToSmall :exception; begin Start := ((Result'length - S'length) / 2) + 1; Finish := Start + S'length - 1; if S'length > Width then raise BufferToSmall; else Result(Start..Finish) := S(S'range); return Result; end if; end Center; -------------------------------------------------------------------------- function RightJustify ( --| Right justify the string S in a buffer --| whose width is Width. S :in String; Width :in positive ) return String is Result :String(1..Width) := (others => ' '); Start :positive; Finish :positive; BufferToSmall :exception; begin if S'length > Width then raise BufferToSmall; else Start := (Result'length - S'length) + Result'first; Finish := Result'last; Result (Start..Finish) := S(S'range); return Result; end if; end RightJustify; -------------------------------------------------------------------------- function LeftJustify ( --| Left justify the string S in a buffer --| of blanks whose width is Width. S :in String; Width :in positive ) return String is Finish :positive; Result :String (1..Width) := (others => ' '); BufferToSmall :exception; begin if S'length > Width then raise BufferToSmall; else Finish := Result'first + S'length - 1; Result (Result'first..Finish) := S(S'range); return Result; end if; end LeftJustify; -------------------------------------------------------------------------- function StripTrailingBlanks ( --| Remove all trailing blanks from --| a string. Token :in String ) return String is begin for i in reverse Token'range loop if Token(i) /= ' ' then -- ith character is not a blank so return -- Token(Token'first..i) return Token(Token'first..i); end if; end loop; return ""; end StripTrailingBlanks; -------------------------------------------------------------------------- function IntTruncAndConvert ( --| Truncates and Converts an --| integer to a string of a given --| length. I :in integer; Width :in integer ) return String is Result :constant String := integer'image(I); begin -- Since image returns a leading blank the number of -- digits in I is length'Result - 1 if Result'length - 1 > Width then return Result(2..2 + Width - 1); else return Result(2..Result'length); end if; end IntTruncAndConvert; -------------------------------------------------------------------------- function Float_To_Int_Str ( X :in Float ) return String is begin return Integer'Image(Integer(X)); end Float_To_Int_Str; -------------------------------------------------------------------------- function FirstNonBlank ( S :in String ) return natural is Position :natural := S'first; begin while (S(Position) = ' ') and (Position <= S'last) loop Position := Position + 1; end loop; if Position in S'Range then return Position; else return 0; end if; end FirstNonBlank; -------------------------------------------------------------------------- function Float_To_Dec_Str ( X :in Float ) return String is TimesX :Float; begin --| OVERVIEW --| This function takes a Float and returns the image of the --| number in decimal notation. The number it returns has two --| places to the right of the decimal point or if the number is --| an integer it leaves two blanks. if X < 0.01 then return "<0.01"; elsif X > 1000000.0 then return ">1000000 "; end if; TimesX := X * 100.0; declare StrTimesX: constant String := Integer'Image(Integer(TimesX)); Result :String (1..StrTimesX'length + 1); FirstDigitPos :positive; LastDigitPos :positive; NumberOfDigits :positive; DecimalFillSpaces :constant String := " "; --| This ensures that there are three spaces to the right of --| ones places. This keeps all the numbers in line. begin if Integer(TimesX) = 0 then return "0" & DecimalFillSpaces ; else FirstDigitPos := FirstNonBlank (StrTimesX); NumberOfDigits := StrTimesX'last - FirstDigitPos + 1; if StrTimesX(StrTimesX'last - 1..StrTimesx'Last) = "00" then return StrTimesX(StrTimesX'First..StrTimesx'last - 2) & DecimalFillSpaces; end if; case NumberOfDigits is when 1 => Result(1..2) := ".0"; return Result(1..2) & StrTimesX (FirstDigitPos); when 2 => Result(1) := '.'; Result(2..3) := StrTimesX (FirstDigitPos..FirstDigitPos + NumberOfDigits -1); return Result (1..3); when others => LastDigitPos := FirstDigitPos + NumberOfDigits - 1; Result(1..NumberOfDigits - 2) := StrTimesX (FirstDigitPos..LastDigitPos - 2); Result(NumberOfDigits - 2 + 1) := '.'; Result(NumberOfDigits..NumberOfDigits + 1) := StrTimesX (LastDigitPos - 1..LastDigitPos); return Result (1..NumberOfDigits + 1); end case; end if; end; end Float_To_Dec_Str; -------------------------------------------------------------------------- procedure InsertInBuffer ( --| Insert the string "Insert" into Buffer --| preceeding a right Justified Field --| and a field which may have to be --| truncated with at least one blank. --| A left justified field does not have --| a blank preceeding it. Buffer :in out String; Insert :in String; StartPos :in positive; EndPos :in positive ) is begin Buffer (StartPos..EndPos) := Insert(Insert'Range); end InsertInBuffer; -------------------------------------------------------------------------- procedure PrintBlockId ( --| This procedure prints the identifying --| information for a block when producing --| the report. BlockId: in BlockIdType ) is begin --| OVERVIEW --| This prints --| 1. the kind of block --| 2. whether the block is a spec or body --| 3. the name of the block --| 4. the line number where the block appears in the source --| ALGORITHM --| Check if this is a declare block which is unnamed. If it is --| then process it differently. if BlockId.KindOfBlock = Definitions.declare_block and then BlockId.BlockName.all( BlockId.BlockName.all'first..BlockId.BlockName.all'last )= "" then Put ("UNNAMED DECLARE BLOCK"); else Put (StripTrailingBlanks (BlockStrings(BlockId.KindOfBlock))); Put (" "); Put (StripTrailingBlanks (BlockId.SpcBdyId)); Put (" OF "); Put ( BlockId.BlockName.all( BlockId.BlockName.all'first..BlockId.BlockName.all'last ) ); end if; Put (" AT LINE "); Put (BlockId.LineLocation); New_Line (Spacing => 2); end PrintBlockId; -------------------------------------------------------------------------- procedure PrintInfo ( BlockId: in BlockIdType; Metrics: in MetricsRecord ) is subtype BufferType is String (1..MaxLineLength); Output :BufferType; Blanks :BufferType := (others => ' '); LabelLength :constant positive := 20; subtype LabelType is String (1..LabelLength); subtype Metric_Index is natural range 1..NumberOfMetrics + 1; MetricLabels :constant array (Metric_Index) of LabelType:= ( "UNIQUE OPERATORS ", "UNIQUE OPERANDS ", "TOTAL OPERATORS ", "TOTAL OPERANDS ", "VOCABULARY ", " ", "PROGRAM LENGTH ", "ESTIMATED LENGTH ", "PROGRAM VOLUME ", "POTENTIAL VOLUME ", "PROGRAM LEVEL ", "ESTIMATED LEVEL ", "INTELLIGENCE CONTENT", "PROGRAMMING EFFORT ", "PROGRAMMING TIME ", "LANGUAGE LEVEL ", "DELIVERED ERRORS ", "ESTIMATED ERRORS " ); --| This array has one extra space for a metric. This is --| to make producing the report easier. subtype metric_range is integer range 1..NumberOfMetrics + 1; ProcessArray :array (metric_Range) of Float; --| This array has one extra space for a metric. This is --| to make producing the report easier. NumberOfMetricLines :constant positive := 9; FirstColValueField :positive; -- := LabelLength + 2; FirstCol :constant positive := 1; EndFirstCol :constant positive := 38; SecondCol :constant positive := 41; EndSecondCol :constant positive := 80; SecondColValueField :positive; -- := SecondCol+LabelLength+2- 1; i :integer; begin --| OVERVIEW --| This procedure produces the report for a block. The format of --| the report is the following: --| --|--------------------------------------------------------------- --| HALSTEAD COMPLEXITY FOR THE SPECIFICATION OF LIBRARY UNIT C36205D --| --| --| PROCEDURE SPECIFICATION OF C36205D AT LINE 12 --| --| UNIQUE OPERATORS 5 UNIQUE OPERANDS <0.01 --| TOTAL OPERATORS 6 TOTAL OPERANDS <0.01 --| VOCABULARY 5 --| PROGRAM LENGTH 6 ESTIMATED LENGTH 11.61 --| PROGRAM VOLUME 13.93 POTENTIAL VOLUME 2 --| PROGRAM LEVEL .14 ESTIMATED LEVEL <0.01 --| INTELLIGENCE CONTENT <0.01 PROGRAMMING EFFORT 97.06 --| PROGRAMMING TIME 19.41 LANGUAGE LEVEL .29 --| DELIVERED ERRORS <0.01 ESTIMATED ERRORS <0.01 --| --|--------------------------------------------------------------- --| The object FirstCol refers to the labels on the left hand side --| of the report. These are UNIQUE OPERATORS, TOTAL OPERATORS --| and so on. FirstColValueField is the refers to the leftmost --| position of the field where the numbers appear. --| The object SecondCol refers to the leftmost position of the --| labels for the second column. These are UNIQUE OPERANDS, --| TOTAL OPERANDS and so forth. SecondColValueField refers to --| the leftmost position of the value field. In this report --| are left justified or right justified in relation to a field. FirstColValueField := LabelLength + 2; SecondColValueField := SecondCol + LabelLength + 2 - 1; PrintBlockId (BlockId); ProcessArray(1) := Metrics.UniqueOperators; ProcessArray(2) := Metrics.UniqueOperands; ProcessArray(3) := Metrics.OperatorUsage; ProcessArray(4) := Metrics.OperandUsage; ProcessArray(5) := Metrics.Vocabulary; ProcessArray(6) := 0.0; ProcessArray(7) := Metrics.ProgramLength; ProcessArray(8) := Metrics.EstimatedProgramLength; ProcessArray(9) := Metrics.ProgramVolume; ProcessArray(10) := Metrics.PotentialVolume; ProcessArray(11) := Metrics.ProgramLevel; ProcessArray(12) := Metrics.ProgramLevelApprox; ProcessArray(13) := Metrics.IntelligenceContent; ProcessArray(14) := Metrics.ProgrammingEffort; ProcessArray(15) := Metrics.ProgrammingTime; ProcessArray(16) := Metrics.LanguageLevel; ProcessArray(17) := Metrics.NumberOfDeliveredErrors; ProcessArray(18) := Metrics.ApproxNumberOfDeliveredErrors; Output := Blanks; for j in 1..NumberOfMetricLines loop i := (j * 2) - 1; InsertInBuffer (Output, MetricLabels(i), FirstCol, LabelLength); InsertInBuffer (Output, RightJustify ( Float_To_Dec_Str (ProcessArray(i)), EndFirstCol - FirstColValueField + 1 ), FirstColValueField, EndFirstCol); -- Only do the following if i is not equal to 5 because -- if i equals 5 then we are processing the third line -- which doesn't have a second column so skip it. if i /= 5 then InsertInBuffer (Output, MetricLabels(i + 1), SecondCol, SecondCol + LabelLength - 1); InsertInBuffer (Output, RightJustify ( Float_To_Dec_Str (ProcessArray(i + 1) ), EndSecondCol - SecondColValueField + 1 ), SecondColValueField, EndSecondCol); end if; Put_Line (Output); Output := Blanks; end loop; -- Clear screen if printing to terminal. -- If writing to a file add two lines of spacing. if ToTerminal then New_Line (Spacing => NumberOfLinesToClearScreen); else New_Line (Spacing => 2); end if; end PrintInfo; -------------------------------------------------------------------------- function CopyQualifiedName ( FullyQualifiedName :in StringPtr ) return StringPtr is begin return new String ' (FullyQualifiedName.all); end CopyQualifiedName; -------------------------------------------------------------------------- procedure ExtendQualifiedName ( QualifiedName :in out StringPtr; Extension :in String ) is --| ALGORITHM --| Concatentate FullyQualifiedName with "." and the Extension --| then return the access to this. Free the space used by the --| QualifiedName. begin if Extension /= "" then if QualifiedName.all /= "" then QualifiedName := new String ' (QualifiedName.all & "." & Extension); else QualifiedName := new String ' (Extension); end if; end if; end ExtendQualifiedName; -------------------------------------------------------------------------- procedure TruncateQualifiedName ( FullyQualifiedName :in out StringPtr ) is --| ALGORITHM --| Remove the last qualification from FullyQualifiedName. --| When changing FullyQualifiedName free the space used by the --| old value. Trash :StringPtr := FullyQualifiedName; begin for i in reverse FullyQualifiedName.all'range loop if FullyQualifiedName(i) = '.' then FullyQualifiedName := new String ' (FullyQualifiedName(FullyQualifiedName.all'first..i-1)); Free (Trash); return; end if; end loop; Free (Trash); FullyQualifiedName := new String ' (""); end TruncateQualifiedName; -------------------------------------------------------------------------- -------------------------------------------------------------------------- -- VISIBLE SUBPROGRAMS -------------------------------------------------------------------------- -------------------------------------------------------------------------- procedure ReportHeader ( UnitName : String; Spec : boolean ) is begin if Spec then Put_Line ( Center ( "HALSTEAD COMPLEXITY FOR THE SPECIFICATION OF" & " LIBRARY UNIT " & UnitName, MaxLineLength ) ); else Put_Line ( Center ("HALSTEAD COMPLEXITY FOR THE BODY OF LIBRARY UNIT " & UnitName, MaxLineLength ) ); end if; New_Line (Spacing => 2); end ReportHeader; -------------------------------------------------------------------------- procedure InitializeData ( LibraryUnit :in String; IsUnitSpec :in boolean; VerboseFlag :in boolean; ToTerminalFlag :in boolean; OuterMostBlockFlag :in boolean ) is begin UnitName := new String ' (LibraryUnit(LibraryUnit'range)); FullyQualifiedName := new String ' (""); UnitSpec := IsUnitSpec; VerboseOn := VerboseFlag; ToTerminal := ToTerminalFlag; OuterMostBlockSeen := OuterMostBlockFlag; if ToTerminal then New_Page; end if; end InitializeData; -------------------------------------------------------------------------- procedure IncrementToken ( T :in TokenItem ) is begin CurrentBlock.TokenCount(T) := CurrentBlock.TokenCount(T) + 1; end IncrementToken; -------------------------------------------------------------------------- procedure FreeSpace ( CurrentBlock :in out BlockInfoType ) is begin Literal_Set.Destroy (CurrentBlock.SetOfLiterals); DEF_ID_Set.Destroy (CurrentBlock.SetOfDEF_IDs); end FreeSpace; -------------------------------------------------------------------------- function InitializeCurrentBlock return BlockInfoType is ClearedBlock :BlockInfoType; begin for t in TokenItem loop ClearedBlock.TokenCount(t) := 0; end loop; ClearedBlock.BlockId.BlockName := null; ClearedBlock.BlockId.KindOfBlock := declare_block; ClearedBlock.BlockId.SpcBdyId := AnonId; ClearedBlock.SetOfLiterals := Literal_Set.Create; ClearedBlock.SetOfDEF_IDs := DEF_ID_Set.Create; return ClearedBlock; end InitializeCurrentBlock; -------------------------------------------------------------------------- function LineNumber ( Position :in MLSP.Source_Position ) return MLSP.Source_Line is -- Get the line number of Position. begin return MLSP.Line (Position.first_location); end LineNumber; -------------------------------------------------------------------------- function IsSourceRange ( Position :in MLSP.Source_Position ) return boolean is --| ALGORITHM --| If Position.first_position /= Position.last_position then --| Position is a range and return true --| else --| Position is not a range and return false begin return not MLSP."=" (Position.first_location, Position.last_location); end; -------------------------------------------------------------------------- procedure SetBlockId ( ScopeName :in Symbol_repNode.Locator; KindOfBlock :in BlockKind; SpcBdyId :in SpcBdyIdType; Line_Number :in MLSP.Source_Line ) is begin -- If the ScopeName is "" then we have an unamed declare block. if SymRepToString (ScopeName) = "" then CurrentBlock.BlockId.BlockName := new String ' (""); else ExtendQualifiedName ( FullyQualifiedName, SymRepToString (ScopeName) ); CurrentBlock.BlockId.BlockName := CopyQualifiedName (FullyQualifiedName); end if; CurrentBlock.BlockId.KindOfBlock := KindOfBlock; CurrentBlock.BlockId.SpcBdyId := SpcBdyId; CurrentBlock.BlockId.LineLocation := Line_Number; end SetBlockId; -------------------------------------------------------------------------- procedure ProcessBlockInfo ( BlockInfo: in BlockInfoType ) is Nn :CT.NnInfoType; --| The counts in Nn represent the counts of operators and --| operands for Literal_Analysis and DEF_ID_Analysis. NnToken :CT.NnInfoType; --| This object keeps the counts of operators and operands --| which pertain to the reserved words and other syntactic --| constructs. Metrics :MetricsRecord; N2Star :natural := 0; begin if VerboseOn then Put_Line (Standard_Output, "DEF_ID_Analysis "); end if; DEF_ID_Analysis (BlockInfo.SetOfDEF_IDs, Nn, N2Star); if VerboseOn then Put_Line (Standard_Output, "Literal_Analysis"); end if; Literal_Analysis (BlockInfo.SetOfLiterals, Nn); CT.ZeroCount (NnToken); C.HalsteadCount (BlockInfo.TokenCount, VerboseOn, NnToken); if VerboseOn then New_Line (Standard_Output); Put_Line (Standard_Output,"------------------------------"); Put_Line (Standard_Output,"This separates countable units"); Put_Line (Standard_Output,"------------------------------"); New_Line (Standard_Output); end if; MetricCalculations ( CT.AddCounts (Nn, NnToken), N2Star, Metrics ); if ToTerminal then -- This block is needed because the boot seems to -- have trouble with -- ReportHeader (UnitName.all,UnitSpec); -- UnitName.all is causing the problem. declare LocalString : constant String := UnitName.all(UnitName.all'range); begin ReportHeader (LocalString, UnitSpec); end; end if; PrintInfo (BlockInfo.BlockId, Metrics); -- Truncate the current Scope Name. TruncateQualifiedName (FullyQualifiedName); end ProcessBlockInfo; -------------------------------------------------------------------------- end Halstead_Data_Base; :::::::::::::: hdb.spc :::::::::::::: -- $Source :/nosc/work/tools/halstead/RCS/utils.spc,v $ -- $Revision :1.11 $ -- $Date: 85/02/21 08:22:23 $ -- $Author: buddy $ with St_Diana; use St_Diana; with Definitions; use Definitions; with ML_Source_Position_Pkg; package Halstead_Data_Base is --| OVERVIEW --| This package holds the major global data structures and subprograms --| used to implement the Halstead Complexity Measures. --| EFFECTS --| This package has the data structures and subprograms used to compute --| the Halstead measures. ProcessBlock organizes the processing of the --| block's information. This entails counting the tokens as either --| operators or operands, determining the operand and operator Vocabulary --| and counting the total usage of operators and operands. --| It also involves counting the number of literals and performing --| analysis on all the identifiers in the block. Keeping track of the --| literals is performed by AddLiteral. This maintains a counted set --| of all the literals in the current block. The literal are counted --| as operands in the Halstead metrics. --| Analyzing the identifiers in the block is done in the subprogram --| DEF_ID_ANALYS.The identifiers are classified according to semantic --|information provided by DIANA. --| TUNING --| The procedure IncrementToken should be in lined using a pragma. -------------------------------------------------------------------------- -- VISIBLE OBJECTS -------------------------------------------------------------------------- package MLSP renames ML_Source_Position_Pkg; CurrentBlock :BlockInfoType; --| This contains the information about the block currently --| being processed. When a new block is encountered it is --| this information which gets pushed on the stack. BlockStack :BlockInfoStack.Stack; --| This structure stacks the information in the current block . --| Thus information is pushed onto the stack when we enter a --| new block and popped from the stack when we exit a block. --| This is used to reflect the visibility of operators and --| operands. OutermostBlockSeen :boolean; --| This is used to indicate that the outermost scope of the --| compilation unit has been seen. This is necessary because --| to include the context clauses as adding to the complexity of --| the outermost compilation unit. FullyQualifiedName :StringPtr; --| This is the fully qualified name of the current scope. This --| string is used in identifying the current scope in the output. UnitName :StringPtr; --| This is the name of library unit currently being processed. --| It is an access to a string since we don't know how long the --| will be. UnitSpec :boolean; --| This indicates whether the unit which is currently being --| processed is a specification or a body. VerboseOn :boolean; --| This boolean is used to control the printing of --| information pertaining to token counting. This shows --| tokens are counted, and what they are counted as. --| This information is always written to standard output. --| This paramater is set from the command line. The default --| for this is false. ToTerminal :boolean; --| This boolean is true if the user has not specified an output --| file which means the report is going to standard_output --| which is the terminal. -------------------------------------------------------------------------- -- VISIBLE SUBPROGRAMS -------------------------------------------------------------------------- -------------------------------------------------------------------------- procedure InitializeData ( --| This procedure passes the values --| of certain --| from the driver to this package which uses --| it in producing the report. It needs the --| the name of the library unit, whether the --| library unit is a specicification or a body, --| if the verbose flag is set, and whether the --| report is going to the terminal. LibraryUnit :in String; IsUnitSpec :in boolean; VerboseFlag :in boolean; ToTerminalFlag :in boolean; OuterMostBlockFlag :in boolean ); -------------------------------------------------------------------------- procedure ReportHeader ( --| This prints the header for a Library --| Unit. UnitName : String; Spec : boolean ); -------------------------------------------------------------------------- function InitializeCurrentBlock --| This function returns a record --| of type BlockInfoType which is --| initialized. return BlockInfoType; --| OVERVIEW --| This function is used before starting the scan of DIANA and --| then after a Push of CurrentBlock onto the stack. --| EFFECTS --| This function sets the TokenCount for each TokenItem to be 0. --| It also set the LiterSet to be empty and the ListOfDEF_ID to --| empty. -------------------------------------------------------------------------- procedure IncrementToken ( --| This procedure increments the count of --| of the given token for the current --| block. T :in TokenItem --| Token whose count is being incremented. ); --| OVERVIEW --| This procedure is called during the tree walking when the DIANA --| node which corresponds to the token T has been scanned. --| MODIFIES --| This increments CurrentBlock.TokenCount (T) which is the --| number of occurrences of the token T in the current block. --| TUNING --| This procedure should be pragma inlined. -------------------------------------------------------------------------- function LineNumber ( Position :in MLSP.Source_Position ) return MLSP.Source_Line; --| RAISES --| --| OVERVIEW --| Checks whether Position is a Source_Location or source_range. --| It then returns the line number of the starting position. --| EFFECTS --| --| REQUIRES --| --| MODIFIES --| --| ERRORS --| --| N/A --| --| TUNING --| --| NOTES --| -------------------------------------------------------------------------- function IsSourceRange ( Position :in MLSP.Source_Position ) return boolean; --| RAISES --| --| OVERVIEW --| This procedure checks if the Position is a source range. In --| the diana this indicate that the token had a beginning source --| location and an ending source location. Other tokens simply --| had a source point which was where the start of the token --| was in the source ( a line number and column position). --| The distinction between source_range and source_point is --| useful for distinguishing certain diana constructs. -------------------------------------------------------------------------- procedure SetBlockId ( --| This procedure initializes the --| identifying fields for the block. ScopeName :in Symbol_repNode.Locator; --| This is a Locator to the name of the block. KindOfBlock :in BlockKind; --| This is the kind of block. This can be a procedure, --| function, package, task or declare block. SpcBdyId :in SpcBdyIdType; --| This indicates whether the block is a spec or a body. Line_Number :in MLSP.Source_Line ); --| OVERVIEW --| This is used in the tree walk of DIANA when a node is --| scanned which indicates the name and type of the block. --| Typically a DEF_ID will be associated with a package, or --| subprogram, or task. The information passed to the --| routine is used in the reporting phase. --| MODIFIES --| This updates the BlockId component of CurrentBlock. --| EFFECTS --| The information in BlockId is used in the output routines to --| indicate the block. -------------------------------------------------------------------------- procedure FreeSpace ( --| Frees all the heap space which this --| record uses. CurrentBlock :in out BlockInfoType ); -------------------------------------------------------------------------- procedure ProcessBlockInfo ( --| Processes the information gathered --| for the current block. BlockInfo :in BlockInfoType --| This is the information for the block. ); --| OVERVIEW --| This procedure computes and output the Halstead Metrics for the --| current block. This procedure is invoked in the DIANA treewalk --| after a node which is a block has been completely processed. -------------------------------------------------------------------------- end Halstead_Data_Base; :::::::::::::: id_utils.bdy :::::::::::::: -- $Revision: 1.2 $ -- $Date: 86/02/06 18:05:16 $ -- $Author: buddy $ with ML_Source_Position_Pkg; package body Identifier_Utilities is package MLSP renames ML_Source_Position_Pkg; --| OVERVIEW --| This package has utilities which are used in processing --| DEF_ID's. function Is_Source_Position_Null ( Position :in MLSP.Source_Position ) return boolean; --| OVERVIEW --| This procedure returns true if the source position passed in --| is null. This means that column and line of the --| Position.first_location is 0. function Is_Id_Null ( Id :in DEF_ID.Locator ) return boolean is begin return Is_Source_Position_Null (lx_srcpos (id)); end; -------------------------------------------------------------------------- function Is_Source_Position_Null ( Position :in MLSP.Source_Position ) return boolean is begin return MLSP."=" (Position.first_location,0); end; end Identifier_Utilities; -------------------------------------------------------------------------- :::::::::::::: id_utils.spc :::::::::::::: with ST_DIANA; use ST_DIANA; package Identifier_Utilities is --| OVERVIEW --| This package has utilities which are used in processing --| DEF_ID's. function Is_Id_Null ( Id :in DEF_ID.Locator ) return boolean ; end Identifier_Utilities; :::::::::::::: ihagg_nam.dat :::::::::::::: -- Begin: IHagg_named dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package agg_named_IH is type RecType is record ih_inagg_named : boolean; end record; R : RecType; end agg_named_IH; -- End: IHagg_named dat ----------------------------------------------------- :::::::::::::: ihblock_s.dat :::::::::::::: -- Begin: IHblock_stm dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package block_stm_IH is type RecType is record ih_inblock : boolean; end record; R : RecType; end block_stm_IH; -- End: IHblock_stm dat ----------------------------------------------------- :::::::::::::: ihcase_al.dat :::::::::::::: -- Begin: IHcase_alternative dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package case_alternative_IH is type RecType is record ih_incase_alternative : boolean; end record; R : RecType; end case_alternative_IH; -- End: IHcase_alternative dat ----------------------------------------------------- :::::::::::::: ihgeneric.dat :::::::::::::: -- Begin: IHgeneric_header dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package generic_header_IH is type RecType is record ih_ingeneric_param : boolean; end record; R : RecType; end generic_header_IH; -- End: IHgeneric_header dat ----------------------------------------------------- :::::::::::::: ihhandler.dat :::::::::::::: -- Begin: IHhandler_alternative dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package handler_alternative_IH is type RecType is record ih_inhandler_alternative : boolean; end record; R : RecType; end handler_alternative_IH; -- End: IHhandler_alternative dat ----------------------------------------------------- :::::::::::::: ihinner_r.dat :::::::::::::: -- Begin: IHinner_record dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package inner_record_IH is type RecType is record ih_in_variant : boolean; end record; R : RecType; end inner_record_IH; -- End: IHinner_record dat ----------------------------------------------------- :::::::::::::: ihseries_.dat :::::::::::::: -- Begin: IHSERIES_UNIT dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package SERIES_UNIT_IH is type RecType is record ih_inlist : boolean; end record; R : RecType; end SERIES_UNIT_IH; -- End: IHSERIES_UNIT dat ----------------------------------------------------- :::::::::::::: ihsubtype.dat :::::::::::::: -- Begin: IHsubtype_decl dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package subtype_decl_IH is type RecType is record ih_in_subtype_decl : boolean; end record; R : RecType; end subtype_decl_IH; -- End: IHsubtype_decl dat ----------------------------------------------------- :::::::::::::: ihtask_de.dat :::::::::::::: -- Begin: IHtask_decl dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package task_decl_IH is type RecType is record ih_intask_decl : boolean; end record; R : RecType; end task_decl_IH; -- End: IHtask_decl dat ----------------------------------------------------- :::::::::::::: ihtype_de.dat :::::::::::::: -- Begin: IHtype_decl dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with ST_Diana; use ST_Diana; with Unchecked_Deallocation; package type_decl_IH is type RecType is record ih_typespec : Anykind; ih_basetype : DEF_ID.Locator; end record; R : RecType; end type_decl_IH; -- End: IHtype_decl dat ----------------------------------------------------- :::::::::::::: ihvariabl.dat :::::::::::::: -- Begin: IHvariable_decl dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with ST_Diana; use ST_Diana; with Unchecked_Deallocation; package variable_decl_IH is type RecType is record ih_vartype : MARK.Locator; ih_init : boolean; end record; R : RecType; end variable_decl_IH; -- End: IHvariable_decl dat ----------------------------------------------------- :::::::::::::: obj.bdy :::::::::::::: -- Begin: SCOBJECT_TYPE bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with TYPE_SPEC_Pkg; use TYPE_SPEC_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with CONSTRAINT_Pkg; use CONSTRAINT_Pkg; with subtype_decl_IH; package body OBJECT_TYPE_Pkg is procedure Scan_OBJECT_TYPE(Root : OBJECT_TYPE.Locator) is begin case Kind(Root) is when object_type_anon_arrayKind => Scan_object_type_anon_array(Root); when object_type_anon_taskKind => Scan_object_type_anon_task(Root); when object_type_constrainedKind => Scan_object_type_constrained(Root); when object_type_indexKind => Scan_object_type_index(Root); when object_type_rangeKind => Scan_object_type_range(Root); when others => null; end case; end Scan_OBJECT_TYPE; procedure Scan_object_type_anon_array(Root : object_type_anon_arrayNode.Locator) is begin Scan_constrained_array_type(as_array_type_spec(Root)); end Scan_object_type_anon_array; procedure Scan_object_type_anon_task(Root : object_type_anon_taskNode.Locator) is begin Scan_task_spec(as_task_spec(Root)); end Scan_object_type_anon_task; procedure Scan_object_type_constrained(Root : object_type_constrainedNode.Locator) is begin if not MARK.IsNull(as_constrained_name(Root)) then Scan_MARK(as_constrained_name(Root)); end if; if not CONSTRAINT.IsNull(as_constraint(Root)) then if (subtype_decl_IH.R.ih_in_subtype_decl) and then (Kind (as_constraint (root)) not in dscrmt_constraintKind) then IncrementToken (rangez); end if; Scan_CONSTRAINT(as_constraint(Root)); end if; end Scan_object_type_constrained; procedure Scan_object_type_index(Root : object_type_indexNode.Locator) is begin if not MARK.IsNull(as_index_name(Root)) then Scan_MARK(as_index_name(Root)); IncrementToken (rangez); end if; end Scan_object_type_index; procedure Scan_object_type_range(Root : object_type_rangeNode.Locator) is begin if not RANGE_CONSTRAINT_CLASS.IsNull(as_range_constraint(Root)) then Scan_RANGE_CONSTRAINT_CLASS(as_range_constraint(Root)); end if; end Scan_object_type_range; end OBJECT_TYPE_Pkg; -- End: SCOBJECT_TYPE bdy ----------------------------------------------------- :::::::::::::: obj.spc :::::::::::::: -- Begin: SCOBJECT_TYPE spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package OBJECT_TYPE_Pkg is procedure Scan_OBJECT_TYPE(Root : OBJECT_TYPE.Locator); procedure Scan_object_type_anon_array(Root : object_type_anon_arrayNode.Locator); procedure Scan_object_type_anon_task(Root : object_type_anon_taskNode.Locator); procedure Scan_object_type_constrained(Root : object_type_constrainedNode.Locator); procedure Scan_object_type_index(Root : object_type_indexNode.Locator); procedure Scan_object_type_range(Root : object_type_rangeNode.Locator); end OBJECT_TYPE_Pkg; -- End: SCOBJECT_TYPE spc ----------------------------------------------------- :::::::::::::: scagg_com.bdy :::::::::::::: -- Begin: SCAGG_COMPONENT bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with agg_named_IH; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with CHOICE_Pkg; use CHOICE_Pkg; package body AGG_COMPONENT_Pkg is procedure Scan_AGG_COMPONENT(Root : AGG_COMPONENT.Locator) is begin case Kind(Root) is when agg_canonicalKind => Scan_agg_canonical(Root); when agg_expKind => Scan_agg_exp(Root); when agg_namedKind => Scan_agg_named(Root); when others => null; end case; end Scan_AGG_COMPONENT; procedure Scan_agg_canonical(Root : agg_canonicalNode.Locator) is Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_agg_canonical; procedure Scan_agg_exp(Root : agg_expNode.Locator) is Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_exp(Root)) then Scan_NAME_EXP(as_exp(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_agg_exp; procedure Scan_agg_named(Root : agg_namedNode.Locator) is as_choice_s_List : SeqOfCHOICE.Generator; as_choice_s_Item : CHOICE.Locator; use SeqOfCHOICE; Old_agg_named_IHR : agg_named_IH.RecType := agg_named_IH.R; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin agg_named_IH.R.ih_inagg_named := false ; SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfCHOICE.IsNull(as_choice_s(Root)) then agg_named_IH.R.ih_inagg_named := true; StartForward(as_choice_s(Root), as_choice_s_List); while not Finished(as_choice_s_List) loop as_choice_s_Item := Cell(as_choice_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (barz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_CHOICE(as_choice_s_Item); Forward(as_choice_s_List); end loop; EndIterate(as_choice_s_List); IncrementToken (arrowz); agg_named_IH.R.ih_inagg_named := false; end if; if not NAME_EXP.IsNull(as_exp(Root)) then Scan_NAME_EXP(as_exp(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; agg_named_IH.R := Old_agg_named_IHR; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_agg_named; end AGG_COMPONENT_Pkg; -- End: SCAGG_COMPONENT bdy ----------------------------------------------------- :::::::::::::: scagg_com.spc :::::::::::::: -- Begin: SCAGG_COMPONENT spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package AGG_COMPONENT_Pkg is procedure Scan_AGG_COMPONENT(Root : AGG_COMPONENT.Locator); procedure Scan_agg_canonical(Root : agg_canonicalNode.Locator); procedure Scan_agg_exp(Root : agg_expNode.Locator); procedure Scan_agg_named(Root : agg_namedNode.Locator); end AGG_COMPONENT_Pkg; -- End: SCAGG_COMPONENT spc ----------------------------------------------------- :::::::::::::: scalterna.bdy :::::::::::::: -- Begin: SCALTERNATIVE bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with case_alternative_IH; with handler_alternative_IH; with CHOICE_Pkg; use CHOICE_Pkg; with STM_Pkg; use STM_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with ITEM_Pkg; use ITEM_Pkg; package body ALTERNATIVE_Pkg is procedure Scan_ALTERNATIVE(Root : ALTERNATIVE.Locator) is begin case Kind(Root) is when case_alternativeKind => Scan_case_alternative(Root); when cond_alternativeKind => Scan_cond_alternative(Root); when handler_alternativeKind => Scan_handler_alternative(Root); when pragma_alternativeKind => Scan_pragma_alternative(Root); when select_alternativeKind => Scan_select_alternative(Root); when others => null; end case; end Scan_ALTERNATIVE; procedure Scan_case_alternative(Root : case_alternativeNode.Locator) is as_case_choice_s_List : SeqOfCHOICE.Generator; as_case_choice_s_Item : CHOICE.Locator; use SeqOfCHOICE; as_stm_s_List : SeqOfSTM.Generator; as_stm_s_Item : STM.Locator; use SeqOfSTM; Old_case_alternative_IHR : case_alternative_IH.RecType := case_alternative_IH.R; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin case_alternative_IH.R.ih_incase_alternative := false ; SERIES_UNIT_IH.R.ih_inlist := false ; case_alternative_IH.R.ih_incase_alternative := true; IncrementToken (when_case_stmz); IncrementToken (arrowz); if not SeqOfCHOICE.IsNull(as_case_choice_s(Root)) then StartForward(as_case_choice_s(Root), as_case_choice_s_List); while not Finished(as_case_choice_s_List) loop as_case_choice_s_Item := Cell(as_case_choice_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (barz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_CHOICE(as_case_choice_s_Item); Forward(as_case_choice_s_List); end loop; EndIterate(as_case_choice_s_List); end if; if not SeqOfSTM.IsNull(as_stm_s(Root)) then StartForward(as_stm_s(Root), as_stm_s_List); while not Finished(as_stm_s_List) loop as_stm_s_Item := Cell(as_stm_s_List); Scan_STM(as_stm_s_Item); Forward(as_stm_s_List); end loop; EndIterate(as_stm_s_List); end if; case_alternative_IH.R.ih_incase_alternative := false; case_alternative_IH.R := Old_case_alternative_IHR; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_case_alternative; procedure Scan_cond_alternative(Root : cond_alternativeNode.Locator) is as_stm_s_List : SeqOfSTM.Generator; as_stm_s_Item : STM.Locator; use SeqOfSTM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_cond_exp_void(Root)) then if IsSourceRange (lx_srcpos(root)) then IncrementToken (elsifz); end if; end if; if NAME_EXP.IsNull(as_cond_exp_void(Root)) then IncrementToken (else_ifz); end if; if not NAME_EXP.IsNull(as_cond_exp_void(Root)) then Scan_NAME_EXP(as_cond_exp_void(Root)); end if; if not SeqOfSTM.IsNull(as_stm_s(Root)) then if not NAME_EXP.IsNull(as_cond_exp_void(Root)) then IncrementToken (thenz); end if; StartForward(as_stm_s(Root), as_stm_s_List); while not Finished(as_stm_s_List) loop as_stm_s_Item := Cell(as_stm_s_List); Scan_STM(as_stm_s_Item); Forward(as_stm_s_List); end loop; EndIterate(as_stm_s_List); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_cond_alternative; procedure Scan_handler_alternative(Root : handler_alternativeNode.Locator) is as_handler_choice_s_List : SeqOfCHOICE.Generator; as_handler_choice_s_Item : CHOICE.Locator; use SeqOfCHOICE; as_stm_s_List : SeqOfSTM.Generator; as_stm_s_Item : STM.Locator; use SeqOfSTM; Old_handler_alternative_IHR : handler_alternative_IH.RecType := handler_alternative_IH.R; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin handler_alternative_IH.R.ih_inhandler_alternative := false ; SERIES_UNIT_IH.R.ih_inlist := false ; handler_alternative_IH.R.ih_inhandler_alternative := true; IncrementToken (when_exceptionz); IncrementToken (arrowz); if not SeqOfCHOICE.IsNull(as_handler_choice_s(Root)) then StartForward(as_handler_choice_s(Root), as_handler_choice_s_List); while not Finished(as_handler_choice_s_List) loop as_handler_choice_s_Item := Cell(as_handler_choice_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (barz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_CHOICE(as_handler_choice_s_Item); Forward(as_handler_choice_s_List); end loop; EndIterate(as_handler_choice_s_List); end if; if not SeqOfSTM.IsNull(as_stm_s(Root)) then StartForward(as_stm_s(Root), as_stm_s_List); while not Finished(as_stm_s_List) loop as_stm_s_Item := Cell(as_stm_s_List); Scan_STM(as_stm_s_Item); Forward(as_stm_s_List); end loop; EndIterate(as_stm_s_List); end if; handler_alternative_IH.R.ih_inhandler_alternative := false; SERIES_UNIT_IH.R.ih_inlist := false; handler_alternative_IH.R := Old_handler_alternative_IHR; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_handler_alternative; procedure Scan_pragma_alternative(Root : pragma_alternativeNode.Locator) is Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not pragma_declNode.IsNull(as_pragma_alternative(Root)) then Scan_pragma_decl(as_pragma_alternative(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_pragma_alternative; procedure Scan_select_alternative(Root : select_alternativeNode.Locator) is as_stm_s_List : SeqOfSTM.Generator; as_stm_s_Item : STM.Locator; use SeqOfSTM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_select_exp_void(Root)) then IncrementToken (when_selectz); Scan_NAME_EXP(as_select_exp_void(Root)); IncrementToken (arrowz); end if; if not SeqOfSTM.IsNull(as_stm_s(Root)) then StartForward(as_stm_s(Root), as_stm_s_List); while not Finished(as_stm_s_List) loop as_stm_s_Item := Cell(as_stm_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (or_selectz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_STM(as_stm_s_Item); Forward(as_stm_s_List); end loop; EndIterate(as_stm_s_List); end if; SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_select_alternative; end ALTERNATIVE_Pkg; -- End: SCALTERNATIVE bdy ----------------------------------------------------- :::::::::::::: scalterna.spc :::::::::::::: -- Begin: SCALTERNATIVE spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package ALTERNATIVE_Pkg is procedure Scan_ALTERNATIVE(Root : ALTERNATIVE.Locator); procedure Scan_case_alternative(Root : case_alternativeNode.Locator); procedure Scan_cond_alternative(Root : cond_alternativeNode.Locator); procedure Scan_handler_alternative(Root : handler_alternativeNode.Locator); procedure Scan_pragma_alternative(Root : pragma_alternativeNode.Locator); procedure Scan_select_alternative(Root : select_alternativeNode.Locator); end ALTERNATIVE_Pkg; -- End: SCALTERNATIVE spc ----------------------------------------------------- :::::::::::::: scblock_s.bdy :::::::::::::: -- Begin: SCBLOCK_STUB bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with ITEM_Pkg; use ITEM_Pkg; with STM_Pkg; use STM_Pkg; with ALTERNATIVE_Pkg; use ALTERNATIVE_Pkg; with BLOCK_STM_IH; with Source_Position_Utilities; package body BLOCK_STUB_Pkg is procedure Scan_BLOCK_STUB(Root : BLOCK_STUB.Locator) is begin case Kind(Root) is when body_blockKind => Scan_body_block(Root); when body_stubKind => Scan_body_stub(Root); when others => null; end case; end Scan_BLOCK_STUB; procedure Scan_body_block(Root : body_blockNode.Locator) is as_item_s_List : SeqOfITEM.Generator; as_item_s_Item : ITEM.Locator; use SeqOfITEM; as_stm_s_List : SeqOfSTM.Generator; as_stm_s_Item : STM.Locator; use SeqOfSTM; as_handler_s_List : SeqOfhandler_alternativeNode.Generator; as_handler_s_Item : handler_alternativeNode.Locator; use SeqOfhandler_alternativeNode; begin if not SeqOfITEM.IsNull(as_item_s(Root)) then if block_stm_IH.R.ih_inblock then IncrementToken (declarez); block_stm_IH.R.ih_inblock := false; end if; StartForward(as_item_s(Root), as_item_s_List); while not Finished(as_item_s_List) loop as_item_s_Item := Cell(as_item_s_List); Scan_ITEM(as_item_s_Item); Forward(as_item_s_List); end loop; EndIterate(as_item_s_List); end if; if not SeqOfSTM.IsNull(as_stm_s(Root)) then IncrementToken (beginz); StartForward(as_stm_s(Root), as_stm_s_List); while not Finished(as_stm_s_List) loop as_stm_s_Item := Cell(as_stm_s_List); Scan_STM(as_stm_s_Item); Forward(as_stm_s_List); end loop; EndIterate(as_stm_s_List); end if; if not SeqOfhandler_alternativeNode.IsNull(as_handler_s(Root)) then IncrementToken (exceptionz); StartForward(as_handler_s(Root), as_handler_s_List); while not Finished(as_handler_s_List) loop as_handler_s_Item := Cell(as_handler_s_List); Scan_handler_alternative(as_handler_s_Item); Forward(as_handler_s_List); end loop; EndIterate(as_handler_s_List); end if; if not Source_Position_Utilities.Is_Srcpos_Null (lx_srcpos (root)) then IncrementToken (end_beginz); end if; end Scan_body_block; procedure Scan_body_stub(Root : body_stubNode.Locator) is begin --- should be is_separatez not is_packagez IncrementToken (is_separatez); IncrementToken (separatez); end Scan_body_stub; end BLOCK_STUB_Pkg; -- End: SCBLOCK_STUB bdy ----------------------------------------------------- :::::::::::::: scblock_s.spc :::::::::::::: -- Begin: SCBLOCK_STUB spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package BLOCK_STUB_Pkg is procedure Scan_BLOCK_STUB(Root : BLOCK_STUB.Locator); procedure Scan_body_block(Root : body_blockNode.Locator); procedure Scan_body_stub(Root : body_stubNode.Locator); end BLOCK_STUB_Pkg; -- End: SCBLOCK_STUB spc ----------------------------------------------------- :::::::::::::: scchoice.bdy :::::::::::::: -- Begin: SCCHOICE bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with agg_named_IH; with case_alternative_IH; with handler_alternative_IH; with inner_record_IH; package body CHOICE_Pkg is procedure Scan_CHOICE(Root : CHOICE.Locator) is begin case Kind(Root) is when ch_discrete_rangeKind => Scan_ch_discrete_range(Root); when ch_expKind => Scan_ch_exp(Root); when ch_othersKind => Scan_ch_others(Root); when others => null; end case; end Scan_CHOICE; procedure Scan_ch_discrete_range(Root : ch_discrete_rangeNode.Locator) is begin if not OBJECT_TYPE.IsNull(as_discrete_range(Root)) then Scan_OBJECT_TYPE(as_discrete_range(Root)); end if; end Scan_ch_discrete_range; procedure Scan_ch_exp(Root : ch_expNode.Locator) is begin if not NAME_EXP.IsNull(as_exp(Root)) then Scan_NAME_EXP(as_exp(Root)); end if; end Scan_ch_exp; procedure Scan_ch_others(Root : ch_othersNode.Locator) is begin if agg_named_IH.R.ih_inagg_named then IncrementToken (others_aggregatez); end if; if case_alternative_IH.R.ih_incase_alternative then IncrementToken (others_casez); end if; if handler_alternative_IH.R.ih_inhandler_alternative then IncrementToken (others_exceptionz); end if; if inner_record_IH.R.ih_in_variant then IncrementToken (others_variantz); end if; end Scan_ch_others; end CHOICE_Pkg; -- End: SCCHOICE bdy ----------------------------------------------------- :::::::::::::: scchoice.spc :::::::::::::: -- Begin: SCCHOICE spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package CHOICE_Pkg is procedure Scan_CHOICE(Root : CHOICE.Locator); procedure Scan_ch_discrete_range(Root : ch_discrete_rangeNode.Locator); procedure Scan_ch_exp(Root : ch_expNode.Locator); procedure Scan_ch_others(Root : ch_othersNode.Locator); end CHOICE_Pkg; -- End: SCCHOICE spc ----------------------------------------------------- :::::::::::::: sccomp_un.bdy :::::::::::::: -- Begin: SCCOMP_UNIT_CLASS bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with ITEM_Pkg; use ITEM_Pkg; package body COMP_UNIT_CLASS_Pkg is procedure Scan_COMP_UNIT_CLASS(Root : COMP_UNIT_CLASS.Locator) is begin case Kind(Root) is when comp_unitKind => Scan_comp_unit(Root); when others => null; end case; end Scan_COMP_UNIT_CLASS; procedure Scan_comp_unit(Root : comp_unitNode.Locator) is as_context_List : SeqOfITEM.Generator; as_context_Item : ITEM.Locator; use SeqOfITEM; as_pragma_s_List : SeqOfpragma_declNode.Generator; as_pragma_s_Item : pragma_declNode.Locator; use SeqOfpragma_declNode; begin CurrentBlock := InitializeCurrentBlock; BlockStack := BlockInfoStack.Create; -- This adds a dummy frame on the stack so that it is not necessary -- to check when popping the stack at the end of the program -- if the stack has at least one record. BlockInfoStack.Push(BlockStack, CurrentBlock); if Kind (as_unit_body (root)) in subp_declKind then if Kind (as_subp_designator (as_unit_body (root))) in proc_idKind then SetBlockId (lx_symrep (as_subp_designator (as_unit_body (root))), procedure_block, SpcId, LineNumber (lx_srcpos (as_unit_body (root))) ); else SetBlockId (lx_symrep (as_subp_designator (as_unit_body (root))), function_block, SpcId, LineNumber (lx_srcpos (as_unit_body (root))) ); end if; end if; if not SeqOfITEM.IsNull(as_context(Root)) then StartForward(as_context(Root), as_context_List); while not Finished(as_context_List) loop as_context_Item := Cell(as_context_List); Scan_ITEM(as_context_Item); Forward(as_context_List); end loop; EndIterate(as_context_List); end if; if not SeqOfpragma_declNode.IsNull(as_pragma_s(Root)) then StartForward(as_pragma_s(Root), as_pragma_s_List); while not Finished(as_pragma_s_List) loop as_pragma_s_Item := Cell(as_pragma_s_List); Scan_pragma_decl(as_pragma_s_Item); Forward(as_pragma_s_List); end loop; EndIterate(as_pragma_s_List); end if; if not ITEM.IsNull(as_unit_body(Root)) then Scan_ITEM(as_unit_body(Root)); end if; if Kind (as_unit_body (root)) in subp_declKind then ProcessBlockInfo (CurrentBlock); end if; end Scan_comp_unit; end COMP_UNIT_CLASS_Pkg; -- End: SCCOMP_UNIT_CLASS bdy ----------------------------------------------------- :::::::::::::: sccomp_un.spc :::::::::::::: -- Begin: SCCOMP_UNIT_CLASS spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package COMP_UNIT_CLASS_Pkg is procedure Scan_COMP_UNIT_CLASS(Root : COMP_UNIT_CLASS.Locator); procedure Scan_comp_unit(Root : comp_unitNode.Locator); end COMP_UNIT_CLASS_Pkg; -- End: SCCOMP_UNIT_CLASS spc ----------------------------------------------------- :::::::::::::: scconstra.bdy :::::::::::::: -- Begin: SCCONSTRAINT bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with GENERAL_ASSOC_Pkg; use GENERAL_ASSOC_Pkg; with AGG_COMPONENT_Pkg; use AGG_COMPONENT_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with subtype_decl_IH; package body CONSTRAINT_Pkg is procedure Scan_CONSTRAINT(Root : CONSTRAINT.Locator) is begin case Kind(Root) is when RANGE_CONSTRAINT_CLASSKind => Scan_RANGE_CONSTRAINT_CLASS(Root); when REAL_CONSTRAINTKind => Scan_REAL_CONSTRAINT(Root); when apply_constraintKind => Scan_apply_constraint(Root); when dscrmt_constraintKind => Scan_dscrmt_constraint(Root); when index_constraintKind => Scan_index_constraint(Root); when others => null; end case; end Scan_CONSTRAINT; procedure Scan_RANGE_CONSTRAINT_CLASS(Root : RANGE_CONSTRAINT_CLASS.Locator) is begin case Kind(Root) is when range_attribute_constraintKind => Scan_range_attribute_constraint(Root); when range_constraintKind => Scan_range_constraint(Root); when others => null; end case; end Scan_RANGE_CONSTRAINT_CLASS; procedure Scan_range_attribute_constraint(Root : range_attribute_constraintNode.Locator) is begin if not NAME_EXP.IsNull(as_range_exp(Root)) then Scan_NAME_EXP(as_range_exp(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; end Scan_range_attribute_constraint; procedure Scan_range_constraint(Root : range_constraintNode.Locator) is begin if IsSourceRange (lx_srcpos (root)) and then not subtype_decl_IH.R.ih_in_subtype_decl then -- The check for subtype is necessary because in object_type -- we count range if it is a subtype. This check prevents -- us from counting range twice. IncrementToken (rangez); end if; if not NAME_EXP.IsNull(as_range_exp1(Root)) then Scan_NAME_EXP(as_range_exp1(Root)); IncrementToken (dot_dot_rangez); end if; if not NAME_EXP.IsNull(as_range_exp2(Root)) then Scan_NAME_EXP(as_range_exp2(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; end Scan_range_constraint; procedure Scan_REAL_CONSTRAINT(Root : REAL_CONSTRAINT.Locator) is begin case Kind(Root) is when fixed_constraintKind => Scan_fixed_constraint(Root); when float_constraintKind => Scan_float_constraint(Root); when others => null; end case; end Scan_REAL_CONSTRAINT; procedure Scan_fixed_constraint(Root : fixed_constraintNode.Locator) is begin if not NAME_EXP.IsNull(as_delta(Root)) then Scan_NAME_EXP(as_delta(Root)); end if; if not range_constraintNode.IsNull(as_range_constraint(Root)) then Scan_range_constraint(as_range_constraint(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; end Scan_fixed_constraint; procedure Scan_float_constraint(Root : float_constraintNode.Locator) is begin if not NAME_EXP.IsNull(as_digits(Root)) then Scan_NAME_EXP(as_digits(Root)); end if; if not range_constraintNode.IsNull(as_range_constraint(Root)) then Scan_range_constraint(as_range_constraint(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; end Scan_float_constraint; procedure Scan_apply_constraint(Root : apply_constraintNode.Locator) is as_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; begin if not SeqOfGENERAL_ASSOC.IsNull(as_assoc_s(Root)) then StartForward(as_assoc_s(Root), as_assoc_s_List); while not Finished(as_assoc_s_List) loop as_assoc_s_Item := Cell(as_assoc_s_List); Scan_GENERAL_ASSOC(as_assoc_s_Item); Forward(as_assoc_s_List); end loop; EndIterate(as_assoc_s_List); end if; SERIES_UNIT_IH.R.ih_inlist := false; end Scan_apply_constraint; procedure Scan_dscrmt_constraint(Root : dscrmt_constraintNode.Locator) is as_dscrmt_assoc_s_List : SeqOfAGG_COMPONENT.Generator; as_dscrmt_assoc_s_Item : AGG_COMPONENT.Locator; use SeqOfAGG_COMPONENT; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); if not SeqOfAGG_COMPONENT.IsNull(as_dscrmt_assoc_s(Root)) then StartForward(as_dscrmt_assoc_s(Root), as_dscrmt_assoc_s_List); while not Finished(as_dscrmt_assoc_s_List) loop as_dscrmt_assoc_s_Item := Cell(as_dscrmt_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_AGG_COMPONENT(as_dscrmt_assoc_s_Item); Forward(as_dscrmt_assoc_s_List); end loop; EndIterate(as_dscrmt_assoc_s_List); end if; IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_dscrmt_constraint; procedure Scan_index_constraint(Root : index_constraintNode.Locator) is as_discrete_range_s_List : SeqOfOBJECT_TYPE.Generator; as_discrete_range_s_Item : OBJECT_TYPE.Locator; use SeqOfOBJECT_TYPE; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); if not SeqOfOBJECT_TYPE.IsNull(as_discrete_range_s(Root)) then StartForward(as_discrete_range_s(Root), as_discrete_range_s_List); while not Finished(as_discrete_range_s_List) loop as_discrete_range_s_Item := Cell(as_discrete_range_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_OBJECT_TYPE(as_discrete_range_s_Item); Forward(as_discrete_range_s_List); end loop; EndIterate(as_discrete_range_s_List); end if; IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_index_constraint; end CONSTRAINT_Pkg; -- End: SCCONSTRAINT bdy ----------------------------------------------------- :::::::::::::: scconstra.spc :::::::::::::: -- Begin: SCCONSTRAINT spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package CONSTRAINT_Pkg is procedure Scan_CONSTRAINT(Root : CONSTRAINT.Locator); procedure Scan_RANGE_CONSTRAINT_CLASS(Root : RANGE_CONSTRAINT_CLASS.Locator); procedure Scan_range_attribute_constraint(Root : range_attribute_constraintNode.Locator); procedure Scan_range_constraint(Root : range_constraintNode.Locator); procedure Scan_REAL_CONSTRAINT(Root : REAL_CONSTRAINT.Locator); procedure Scan_fixed_constraint(Root : fixed_constraintNode.Locator); procedure Scan_float_constraint(Root : float_constraintNode.Locator); procedure Scan_apply_constraint(Root : apply_constraintNode.Locator); procedure Scan_dscrmt_constraint(Root : dscrmt_constraintNode.Locator); procedure Scan_index_constraint(Root : index_constraintNode.Locator); end CONSTRAINT_Pkg; -- End: SCCONSTRAINT spc ----------------------------------------------------- :::::::::::::: scdef_id.bdy :::::::::::::: --VMS file: %nosc.work.tools.halstead.source*(SCDEF_ID.bdy) --UTS file: /nosccomp/byron/_vms//nosc/work/tools/halstead/COMP/SCDEF_ID.bdy -- Begin: SCDEF_ID bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with variable_decl_IH; with type_decl_IH; with Identifier_Utilities; package body DEF_ID_Pkg is procedure Scan_DEF_ID(Root : DEF_ID.Locator) is begin case Kind(Root) is when ATTRIBUTE_IDKind => Scan_ATTRIBUTE_ID(Root); when BUILT_IN_OPERATORKind => Scan_BUILT_IN_OPERATOR(Root); when GENERAL_TYPE_IDKind => Scan_GENERAL_TYPE_ID(Root); when LITERAL_IDKind => Scan_LITERAL_ID(Root); when OBJECT_IDKind => Scan_OBJECT_ID(Root); when PKG_ID_CLASSKind => Scan_PKG_ID_CLASS(Root); when PRAGMA_IDKind => Scan_PRAGMA_ID(Root); when STM_IDKind => Scan_STM_ID(Root); when SUBP_IDKind => Scan_SUBP_ID(Root); when argument_idKind => Scan_argument_id(Root); when exception_idKind => Scan_exception_id(Root); when iteration_idKind => Scan_iteration_id(Root); when number_idKind => Scan_number_id(Root); when subtype_idKind => Scan_subtype_id(Root); when task_body_idKind => Scan_task_body_id(Root); when others => null; end case; end Scan_DEF_ID; procedure Scan_ATTRIBUTE_ID(Root : ATTRIBUTE_ID.Locator) is begin case Kind(Root) is when LRM_ATTRIBUTE_IDKind => Scan_LRM_ATTRIBUTE_ID(Root); when others => null; end case; end Scan_ATTRIBUTE_ID; procedure Scan_LRM_ATTRIBUTE_ID(Root : LRM_ATTRIBUTE_ID.Locator) is begin case Kind(Root) is when address_idKind => Scan_address_id(Root); when aft_idKind => Scan_aft_id(Root); when base_idKind => Scan_base_id(Root); when callable_idKind => Scan_callable_id(Root); when constrained_idKind => Scan_constrained_id(Root); when count_idKind => Scan_count_id(Root); when delta_idKind => Scan_delta_id(Root); when digits_idKind => Scan_digits_id(Root); when emax_idKind => Scan_emax_id(Root); when epsilon_idKind => Scan_epsilon_id(Root); when first_bit_idKind => Scan_first_bit_id(Root); when first_index_idKind => Scan_first_index_id(Root); when first_scalar_idKind => Scan_first_scalar_id(Root); when fore_idKind => Scan_fore_id(Root); when image_idKind => Scan_image_id(Root); when large_idKind => Scan_large_id(Root); when last_bit_idKind => Scan_last_bit_id(Root); when last_index_idKind => Scan_last_index_id(Root); when last_scalar_idKind => Scan_last_scalar_id(Root); when length_idKind => Scan_length_id(Root); when machine_emax_idKind => Scan_machine_emax_id(Root); when machine_emin_idKind => Scan_machine_emin_id(Root); when machine_mantissa_idKind => Scan_machine_mantissa_id(Root); when machine_overflows_idKind => Scan_machine_overflows_id(Root); when machine_radix_idKind => Scan_machine_radix_id(Root); when machine_rounds_idKind => Scan_machine_rounds_id(Root); when mantissa_idKind => Scan_mantissa_id(Root); when pos_idKind => Scan_pos_id(Root); when position_idKind => Scan_position_id(Root); when pred_idKind => Scan_pred_id(Root); when range_idKind => Scan_range_id(Root); when safe_emax_idKind => Scan_safe_emax_id(Root); when safe_large_idKind => Scan_safe_large_id(Root); when safe_small_idKind => Scan_safe_small_id(Root); when size_objects_idKind => Scan_size_objects_id(Root); when size_type_idKind => Scan_size_type_id(Root); when small_idKind => Scan_small_id(Root); when storage_size_collection_idKind => Scan_storage_size_collection_id(Root); when storage_size_task_idKind => Scan_storage_size_task_id(Root); when succ_idKind => Scan_succ_id(Root); when terminated_idKind => Scan_terminated_id(Root); when val_idKind => Scan_val_id(Root); when value_idKind => Scan_value_id(Root); when width_idKind => Scan_width_id(Root); when others => null; end case; end Scan_LRM_ATTRIBUTE_ID; procedure Scan_address_id(Root : address_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_address_id; procedure Scan_aft_id(Root : aft_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_aft_id; procedure Scan_base_id(Root : base_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_base_id; procedure Scan_callable_id(Root : callable_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_callable_id; procedure Scan_constrained_id(Root : constrained_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_constrained_id; procedure Scan_count_id(Root : count_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_count_id; procedure Scan_delta_id(Root : delta_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_delta_id; procedure Scan_digits_id(Root : digits_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_digits_id; procedure Scan_emax_id(Root : emax_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_emax_id; procedure Scan_epsilon_id(Root : epsilon_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_epsilon_id; procedure Scan_first_bit_id(Root : first_bit_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_first_bit_id; procedure Scan_first_index_id(Root : first_index_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_first_index_id; procedure Scan_first_scalar_id(Root : first_scalar_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_first_scalar_id; procedure Scan_fore_id(Root : fore_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_fore_id; procedure Scan_image_id(Root : image_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_image_id; procedure Scan_large_id(Root : large_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_large_id; procedure Scan_last_bit_id(Root : last_bit_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_last_bit_id; procedure Scan_last_index_id(Root : last_index_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_last_index_id; procedure Scan_last_scalar_id(Root : last_scalar_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_last_scalar_id; procedure Scan_length_id(Root : length_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_length_id; procedure Scan_machine_emax_id(Root : machine_emax_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_emax_id; procedure Scan_machine_emin_id(Root : machine_emin_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_emin_id; procedure Scan_machine_mantissa_id(Root : machine_mantissa_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_mantissa_id; procedure Scan_machine_overflows_id(Root : machine_overflows_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_overflows_id; procedure Scan_machine_radix_id(Root : machine_radix_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_radix_id; procedure Scan_machine_rounds_id(Root : machine_rounds_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_rounds_id; procedure Scan_mantissa_id(Root : mantissa_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_mantissa_id; procedure Scan_pos_id(Root : pos_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_pos_id; procedure Scan_position_id(Root : position_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_position_id; procedure Scan_pred_id(Root : pred_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_pred_id; procedure Scan_range_id(Root : range_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_range_id; procedure Scan_safe_emax_id(Root : safe_emax_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_safe_emax_id; procedure Scan_safe_large_id(Root : safe_large_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_safe_large_id; procedure Scan_safe_small_id(Root : safe_small_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_safe_small_id; procedure Scan_size_objects_id(Root : size_objects_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_size_objects_id; procedure Scan_size_type_id(Root : size_type_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_size_type_id; procedure Scan_small_id(Root : small_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_small_id; procedure Scan_storage_size_collection_id(Root : storage_size_collection_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_storage_size_collection_id; procedure Scan_storage_size_task_id(Root : storage_size_task_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_storage_size_task_id; procedure Scan_succ_id(Root : succ_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_succ_id; procedure Scan_terminated_id(Root : terminated_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_terminated_id; procedure Scan_val_id(Root : val_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_val_id; procedure Scan_value_id(Root : value_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_value_id; procedure Scan_width_id(Root : width_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_width_id; procedure Scan_BUILT_IN_OPERATOR(Root : BUILT_IN_OPERATOR.Locator) is begin case Kind(Root) is when built_in_absKind => Scan_built_in_abs(Root); when built_in_andKind => Scan_built_in_and(Root); when built_in_modKind => Scan_built_in_mod(Root); when built_in_notKind => Scan_built_in_not(Root); when built_in_orKind => Scan_built_in_or(Root); when built_in_remKind => Scan_built_in_rem(Root); when built_in_xorKind => Scan_built_in_xor(Root); when concatenateKind => Scan_concatenate(Root); when divideKind => Scan_divide(Root); when equalKind => Scan_equal(Root); when exponentKind => Scan_exponent(Root); when greater_thanKind => Scan_greater_than(Root); when greater_than_or_equalKind => Scan_greater_than_or_equal(Root); when less_thanKind => Scan_less_than(Root); when less_than_or_equalKind => Scan_less_than_or_equal(Root); when minusKind => Scan_minus(Root); when multiplyKind => Scan_multiply(Root); when negateKind => Scan_negate(Root); when not_equalKind => Scan_not_equal(Root); when plusKind => Scan_plus(Root); when unary_plusKind => Scan_unary_plus(Root); when others => null; end case; end Scan_BUILT_IN_OPERATOR; procedure Scan_built_in_abs(Root : built_in_absNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_abs; procedure Scan_built_in_and(Root : built_in_andNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_and; procedure Scan_built_in_mod(Root : built_in_modNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_mod; procedure Scan_built_in_not(Root : built_in_notNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_not; procedure Scan_built_in_or(Root : built_in_orNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_or; procedure Scan_built_in_rem(Root : built_in_remNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_rem; procedure Scan_built_in_xor(Root : built_in_xorNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_xor; procedure Scan_concatenate(Root : concatenateNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_concatenate; procedure Scan_divide(Root : divideNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_divide; procedure Scan_equal(Root : equalNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_equal; procedure Scan_exponent(Root : exponentNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_exponent; procedure Scan_greater_than(Root : greater_thanNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_greater_than; procedure Scan_greater_than_or_equal(Root : greater_than_or_equalNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_greater_than_or_equal; procedure Scan_less_than(Root : less_thanNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_less_than; procedure Scan_less_than_or_equal(Root : less_than_or_equalNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_less_than_or_equal; procedure Scan_minus(Root : minusNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_minus; procedure Scan_multiply(Root : multiplyNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_multiply; procedure Scan_negate(Root : negateNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_negate; procedure Scan_not_equal(Root : not_equalNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_not_equal; procedure Scan_plus(Root : plusNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_plus; procedure Scan_unary_plus(Root : unary_plusNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_unary_plus; procedure Scan_GENERAL_TYPE_ID(Root : GENERAL_TYPE_ID.Locator) is begin case Kind(Root) is when lim_priv_type_idKind => Scan_lim_priv_type_id(Root); when priv_type_idKind => Scan_priv_type_id(Root); when type_idKind => Scan_type_id(Root); when others => null; end case; end Scan_GENERAL_TYPE_ID; procedure Scan_lim_priv_type_id(Root : lim_priv_type_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_lim_priv_type_id; procedure Scan_priv_type_id(Root : priv_type_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_priv_type_id; procedure Scan_type_id(Root : type_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_type_id; procedure Scan_LITERAL_ID(Root : LITERAL_ID.Locator) is begin case Kind(Root) is when def_charKind => Scan_def_char(Root); when enum_idKind => Scan_enum_id(Root); when others => null; end case; end Scan_LITERAL_ID; procedure Scan_def_char(Root : def_charNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_def_char; procedure Scan_enum_id(Root : enum_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_enum_id; procedure Scan_OBJECT_ID(Root : OBJECT_ID.Locator) is begin case Kind(Root) is when PARAM_IDKind => Scan_PARAM_ID(Root); when component_idKind => Scan_component_id(Root); when constant_idKind => Scan_constant_id(Root); when dscrmt_idKind => Scan_dscrmt_id(Root); when variable_idKind => Scan_variable_id(Root); when others => null; end case; end Scan_OBJECT_ID; procedure Scan_PARAM_ID(Root : PARAM_ID.Locator) is begin case Kind(Root) is when in_idKind => Scan_in_id(Root); when in_out_idKind => Scan_in_out_id(Root); when out_idKind => Scan_out_id(Root); when others => null; end case; end Scan_PARAM_ID; procedure Scan_in_id(Root : in_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_in_id; procedure Scan_in_out_id(Root : in_out_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_in_out_id; procedure Scan_out_id(Root : out_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_out_id; procedure Scan_component_id(Root : component_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_component_id; procedure Scan_constant_id(Root : constant_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_constant_id; procedure Scan_dscrmt_id(Root : dscrmt_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_dscrmt_id; procedure Scan_variable_id(Root : variable_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_variable_id; procedure Scan_PKG_ID_CLASS(Root : PKG_ID_CLASS.Locator) is begin case Kind(Root) is when generic_pkg_idKind => Scan_generic_pkg_id(Root); when pkg_idKind => Scan_pkg_id(Root); when others => null; end case; end Scan_PKG_ID_CLASS; procedure Scan_generic_pkg_id(Root : generic_pkg_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_generic_pkg_id; procedure Scan_pkg_id(Root : pkg_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_pkg_id; procedure Scan_PRAGMA_ID(Root : PRAGMA_ID.Locator) is begin case Kind(Root) is when AIE_PRAGMA_IDKind => Scan_AIE_PRAGMA_ID(Root); when LRM_PRAGMA_IDKind => Scan_LRM_PRAGMA_ID(Root); when others => null; end case; end Scan_PRAGMA_ID; procedure Scan_AIE_PRAGMA_ID(Root : AIE_PRAGMA_ID.Locator) is begin case Kind(Root) is when link_name_pragmaKind => Scan_link_name_pragma(Root); when mark_release_pragmaKind => Scan_mark_release_pragma(Root); when monitor_pragmaKind => Scan_monitor_pragma(Root); when unrecognized_pragmaKind => Scan_unrecognized_pragma(Root); when others => null; end case; end Scan_AIE_PRAGMA_ID; procedure Scan_link_name_pragma(Root : link_name_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_link_name_pragma; procedure Scan_mark_release_pragma(Root : mark_release_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_mark_release_pragma; procedure Scan_monitor_pragma(Root : monitor_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_monitor_pragma; procedure Scan_unrecognized_pragma(Root : unrecognized_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_unrecognized_pragma; procedure Scan_LRM_PRAGMA_ID(Root : LRM_PRAGMA_ID.Locator) is begin case Kind(Root) is when controlled_pragmaKind => Scan_controlled_pragma(Root); when elaborate_pragmaKind => Scan_elaborate_pragma(Root); when inline_pragmaKind => Scan_inline_pragma(Root); when interface_pragmaKind => Scan_interface_pragma(Root); when list_pragmaKind => Scan_list_pragma(Root); when memory_size_pragmaKind => Scan_memory_size_pragma(Root); when optimize_pragmaKind => Scan_optimize_pragma(Root); when pack_pragmaKind => Scan_pack_pragma(Root); when page_pragmaKind => Scan_page_pragma(Root); when priority_pragmaKind => Scan_priority_pragma(Root); when shared_pragmaKind => Scan_shared_pragma(Root); when storage_unit_pragmaKind => Scan_storage_unit_pragma(Root); when suppress_pragmaKind => Scan_suppress_pragma(Root); when system_name_pragmaKind => Scan_system_name_pragma(Root); when others => null; end case; end Scan_LRM_PRAGMA_ID; procedure Scan_controlled_pragma(Root : controlled_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_controlled_pragma; procedure Scan_elaborate_pragma(Root : elaborate_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_elaborate_pragma; procedure Scan_inline_pragma(Root : inline_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_inline_pragma; procedure Scan_interface_pragma(Root : interface_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_interface_pragma; procedure Scan_list_pragma(Root : list_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_list_pragma; procedure Scan_memory_size_pragma(Root : memory_size_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_memory_size_pragma; procedure Scan_optimize_pragma(Root : optimize_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_optimize_pragma; procedure Scan_pack_pragma(Root : pack_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_pack_pragma; procedure Scan_page_pragma(Root : page_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_page_pragma; procedure Scan_priority_pragma(Root : priority_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_priority_pragma; procedure Scan_shared_pragma(Root : shared_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_shared_pragma; procedure Scan_storage_unit_pragma(Root : storage_unit_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_storage_unit_pragma; procedure Scan_suppress_pragma(Root : suppress_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_suppress_pragma; procedure Scan_system_name_pragma(Root : system_name_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_system_name_pragma; procedure Scan_STM_ID(Root : STM_ID.Locator) is begin case Kind(Root) is when block_idKind => Scan_block_id(Root); when label_idKind => Scan_label_id(Root); when loop_idKind => Scan_loop_id(Root); when others => null; end case; end Scan_STM_ID; procedure Scan_block_id(Root : block_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_block_id; procedure Scan_label_id(Root : label_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_label_id; procedure Scan_loop_id(Root : loop_idNode.Locator) is begin IncrementToken (colonz); if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_loop_id; procedure Scan_SUBP_ID(Root : SUBP_ID.Locator) is begin case Kind(Root) is when GENERIC_SUBP_IDKind => Scan_GENERIC_SUBP_ID(Root); when def_operatorKind => Scan_def_operator(Root); when entry_idKind => Scan_entry_id(Root); when func_idKind => Scan_func_id(Root); when proc_idKind => Scan_proc_id(Root); when others => null; end case; end Scan_SUBP_ID; procedure Scan_GENERIC_SUBP_ID(Root : GENERIC_SUBP_ID.Locator) is begin case Kind(Root) is when generic_func_idKind => Scan_generic_func_id(Root); when generic_proc_idKind => Scan_generic_proc_id(Root); when others => null; end case; end Scan_GENERIC_SUBP_ID; procedure Scan_generic_func_id(Root : generic_func_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_generic_func_id; procedure Scan_generic_proc_id(Root : generic_proc_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_generic_proc_id; procedure Scan_def_operator(Root : def_operatorNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_def_operator; procedure Scan_entry_id(Root : entry_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_entry_id; procedure Scan_func_id(Root : func_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_func_id; procedure Scan_proc_id(Root : proc_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_proc_id; procedure Scan_argument_id(Root : argument_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_argument_id; procedure Scan_exception_id(Root : exception_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_exception_id; procedure Scan_iteration_id(Root : iteration_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_iteration_id; procedure Scan_number_id(Root : number_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_number_id; procedure Scan_subtype_id(Root : subtype_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_subtype_id; procedure Scan_task_body_id(Root : task_body_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_task_body_id; end DEF_ID_Pkg; -- End: SCDEF_ID bdy ----------------------------------------------------- :::::::::::::: scdef_id.spc :::::::::::::: -- Begin: SCDEF_ID spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package DEF_ID_Pkg is procedure Scan_DEF_ID(Root : DEF_ID.Locator); procedure Scan_ATTRIBUTE_ID(Root : ATTRIBUTE_ID.Locator); procedure Scan_LRM_ATTRIBUTE_ID(Root : LRM_ATTRIBUTE_ID.Locator); procedure Scan_address_id(Root : address_idNode.Locator); procedure Scan_aft_id(Root : aft_idNode.Locator); procedure Scan_base_id(Root : base_idNode.Locator); procedure Scan_callable_id(Root : callable_idNode.Locator); procedure Scan_constrained_id(Root : constrained_idNode.Locator); procedure Scan_count_id(Root : count_idNode.Locator); procedure Scan_delta_id(Root : delta_idNode.Locator); procedure Scan_digits_id(Root : digits_idNode.Locator); procedure Scan_emax_id(Root : emax_idNode.Locator); procedure Scan_epsilon_id(Root : epsilon_idNode.Locator); procedure Scan_first_bit_id(Root : first_bit_idNode.Locator); procedure Scan_first_index_id(Root : first_index_idNode.Locator); procedure Scan_first_scalar_id(Root : first_scalar_idNode.Locator); procedure Scan_fore_id(Root : fore_idNode.Locator); procedure Scan_image_id(Root : image_idNode.Locator); procedure Scan_large_id(Root : large_idNode.Locator); procedure Scan_last_bit_id(Root : last_bit_idNode.Locator); procedure Scan_last_index_id(Root : last_index_idNode.Locator); procedure Scan_last_scalar_id(Root : last_scalar_idNode.Locator); procedure Scan_length_id(Root : length_idNode.Locator); procedure Scan_machine_emax_id(Root : machine_emax_idNode.Locator); procedure Scan_machine_emin_id(Root : machine_emin_idNode.Locator); procedure Scan_machine_mantissa_id(Root : machine_mantissa_idNode.Locator); procedure Scan_machine_overflows_id(Root : machine_overflows_idNode.Locator); procedure Scan_machine_radix_id(Root : machine_radix_idNode.Locator); procedure Scan_machine_rounds_id(Root : machine_rounds_idNode.Locator); procedure Scan_mantissa_id(Root : mantissa_idNode.Locator); procedure Scan_pos_id(Root : pos_idNode.Locator); procedure Scan_position_id(Root : position_idNode.Locator); procedure Scan_pred_id(Root : pred_idNode.Locator); procedure Scan_range_id(Root : range_idNode.Locator); procedure Scan_safe_emax_id(Root : safe_emax_idNode.Locator); procedure Scan_safe_large_id(Root : safe_large_idNode.Locator); procedure Scan_safe_small_id(Root : safe_small_idNode.Locator); procedure Scan_size_objects_id(Root : size_objects_idNode.Locator); procedure Scan_size_type_id(Root : size_type_idNode.Locator); procedure Scan_small_id(Root : small_idNode.Locator); procedure Scan_storage_size_collection_id(Root : storage_size_collection_idNode.Locator); procedure Scan_storage_size_task_id(Root : storage_size_task_idNode.Locator); procedure Scan_succ_id(Root : succ_idNode.Locator); procedure Scan_terminated_id(Root : terminated_idNode.Locator); procedure Scan_val_id(Root : val_idNode.Locator); procedure Scan_value_id(Root : value_idNode.Locator); procedure Scan_width_id(Root : width_idNode.Locator); procedure Scan_BUILT_IN_OPERATOR(Root : BUILT_IN_OPERATOR.Locator); procedure Scan_built_in_abs(Root : built_in_absNode.Locator); procedure Scan_built_in_and(Root : built_in_andNode.Locator); procedure Scan_built_in_mod(Root : built_in_modNode.Locator); procedure Scan_built_in_not(Root : built_in_notNode.Locator); procedure Scan_built_in_or(Root : built_in_orNode.Locator); procedure Scan_built_in_rem(Root : built_in_remNode.Locator); procedure Scan_built_in_xor(Root : built_in_xorNode.Locator); procedure Scan_concatenate(Root : concatenateNode.Locator); procedure Scan_divide(Root : divideNode.Locator); procedure Scan_equal(Root : equalNode.Locator); procedure Scan_exponent(Root : exponentNode.Locator); procedure Scan_greater_than(Root : greater_thanNode.Locator); procedure Scan_greater_than_or_equal(Root : greater_than_or_equalNode.Locator); procedure Scan_less_than(Root : less_thanNode.Locator); procedure Scan_less_than_or_equal(Root : less_than_or_equalNode.Locator); procedure Scan_minus(Root : minusNode.Locator); procedure Scan_multiply(Root : multiplyNode.Locator); procedure Scan_negate(Root : negateNode.Locator); procedure Scan_not_equal(Root : not_equalNode.Locator); procedure Scan_plus(Root : plusNode.Locator); procedure Scan_unary_plus(Root : unary_plusNode.Locator); procedure Scan_GENERAL_TYPE_ID(Root : GENERAL_TYPE_ID.Locator); procedure Scan_lim_priv_type_id(Root : lim_priv_type_idNode.Locator); procedure Scan_priv_type_id(Root : priv_type_idNode.Locator); procedure Scan_type_id(Root : type_idNode.Locator); procedure Scan_LITERAL_ID(Root : LITERAL_ID.Locator); procedure Scan_def_char(Root : def_charNode.Locator); procedure Scan_enum_id(Root : enum_idNode.Locator); procedure Scan_OBJECT_ID(Root : OBJECT_ID.Locator); procedure Scan_PARAM_ID(Root : PARAM_ID.Locator); procedure Scan_in_id(Root : in_idNode.Locator); procedure Scan_in_out_id(Root : in_out_idNode.Locator); procedure Scan_out_id(Root : out_idNode.Locator); procedure Scan_component_id(Root : component_idNode.Locator); procedure Scan_constant_id(Root : constant_idNode.Locator); procedure Scan_dscrmt_id(Root : dscrmt_idNode.Locator); procedure Scan_variable_id(Root : variable_idNode.Locator); procedure Scan_PKG_ID_CLASS(Root : PKG_ID_CLASS.Locator); procedure Scan_generic_pkg_id(Root : generic_pkg_idNode.Locator); procedure Scan_pkg_id(Root : pkg_idNode.Locator); procedure Scan_PRAGMA_ID(Root : PRAGMA_ID.Locator); procedure Scan_AIE_PRAGMA_ID(Root : AIE_PRAGMA_ID.Locator); procedure Scan_link_name_pragma(Root : link_name_pragmaNode.Locator); procedure Scan_mark_release_pragma(Root : mark_release_pragmaNode.Locator); procedure Scan_monitor_pragma(Root : monitor_pragmaNode.Locator); procedure Scan_unrecognized_pragma(Root : unrecognized_pragmaNode.Locator); procedure Scan_LRM_PRAGMA_ID(Root : LRM_PRAGMA_ID.Locator); procedure Scan_controlled_pragma(Root : controlled_pragmaNode.Locator); procedure Scan_elaborate_pragma(Root : elaborate_pragmaNode.Locator); procedure Scan_inline_pragma(Root : inline_pragmaNode.Locator); procedure Scan_interface_pragma(Root : interface_pragmaNode.Locator); procedure Scan_list_pragma(Root : list_pragmaNode.Locator); procedure Scan_memory_size_pragma(Root : memory_size_pragmaNode.Locator); procedure Scan_optimize_pragma(Root : optimize_pragmaNode.Locator); procedure Scan_pack_pragma(Root : pack_pragmaNode.Locator); procedure Scan_page_pragma(Root : page_pragmaNode.Locator); procedure Scan_priority_pragma(Root : priority_pragmaNode.Locator); procedure Scan_shared_pragma(Root : shared_pragmaNode.Locator); procedure Scan_storage_unit_pragma(Root : storage_unit_pragmaNode.Locator); procedure Scan_suppress_pragma(Root : suppress_pragmaNode.Locator); procedure Scan_system_name_pragma(Root : system_name_pragmaNode.Locator); procedure Scan_STM_ID(Root : STM_ID.Locator); procedure Scan_block_id(Root : block_idNode.Locator); procedure Scan_label_id(Root : label_idNode.Locator); procedure Scan_loop_id(Root : loop_idNode.Locator); procedure Scan_SUBP_ID(Root : SUBP_ID.Locator); procedure Scan_GENERIC_SUBP_ID(Root : GENERIC_SUBP_ID.Locator); procedure Scan_generic_func_id(Root : generic_func_idNode.Locator); procedure Scan_generic_proc_id(Root : generic_proc_idNode.Locator); procedure Scan_def_operator(Root : def_operatorNode.Locator); procedure Scan_entry_id(Root : entry_idNode.Locator); procedure Scan_func_id(Root : func_idNode.Locator); procedure Scan_proc_id(Root : proc_idNode.Locator); procedure Scan_argument_id(Root : argument_idNode.Locator); procedure Scan_exception_id(Root : exception_idNode.Locator); procedure Scan_iteration_id(Root : iteration_idNode.Locator); procedure Scan_number_id(Root : number_idNode.Locator); procedure Scan_subtype_id(Root : subtype_idNode.Locator); procedure Scan_task_body_id(Root : task_body_idNode.Locator); end DEF_ID_Pkg; -- End: SCDEF_ID spc ----------------------------------------------------- :::::::::::::: scgeneral.bdy :::::::::::::: -- Begin: SCGENERAL_ASSOC bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; package body GENERAL_ASSOC_Pkg is procedure Scan_GENERAL_ASSOC(Root : GENERAL_ASSOC.Locator) is begin case Kind(Root) is when GA_ASSOC_EXPKind => Scan_GA_ASSOC_EXP(Root); when ga_rangeKind => Scan_ga_range(Root); when others => null; end case; end Scan_GENERAL_ASSOC; procedure Scan_GA_ASSOC_EXP(Root : GA_ASSOC_EXP.Locator) is begin case Kind(Root) is when ga_assocKind => Scan_ga_assoc(Root); when ga_expKind => Scan_ga_exp(Root); when others => null; end case; end Scan_GA_ASSOC_EXP; procedure Scan_ga_assoc(Root : ga_assocNode.Locator) is as_id_s_List : SeqOfused_idNode.Generator; as_id_s_Item : used_idNode.Locator; use SeqOfused_idNode; begin if not SeqOfused_idNode.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); Scan_used_id(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); end if; if not NAME_EXP.IsNull(as_exp(Root)) then Scan_NAME_EXP(as_exp(Root)); end if; end Scan_ga_assoc; procedure Scan_ga_exp(Root : ga_expNode.Locator) is begin if not NAME_EXP.IsNull(as_exp(Root)) then Scan_NAME_EXP(as_exp(Root)); end if; end Scan_ga_exp; procedure Scan_ga_range(Root : ga_rangeNode.Locator) is begin if not OBJECT_TYPE.IsNull(as_apply_discrete_range(Root)) then Scan_OBJECT_TYPE(as_apply_discrete_range(Root)); end if; end Scan_ga_range; end GENERAL_ASSOC_Pkg; -- End: SCGENERAL_ASSOC bdy ----------------------------------------------------- :::::::::::::: scgeneral.spc :::::::::::::: -- Begin: SCGENERAL_ASSOC spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package GENERAL_ASSOC_Pkg is procedure Scan_GENERAL_ASSOC(Root : GENERAL_ASSOC.Locator); procedure Scan_GA_ASSOC_EXP(Root : GA_ASSOC_EXP.Locator); procedure Scan_ga_assoc(Root : ga_assocNode.Locator); procedure Scan_ga_exp(Root : ga_expNode.Locator); procedure Scan_ga_range(Root : ga_rangeNode.Locator); end GENERAL_ASSOC_Pkg; -- End: SCGENERAL_ASSOC spc ----------------------------------------------------- :::::::::::::: scgeneric.bdy :::::::::::::: -- Begin: SCGENERIC_HEADER_CLASS bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with generic_header_IH; with ITEM_Pkg; use ITEM_Pkg; package body GENERIC_HEADER_CLASS_Pkg is procedure Scan_GENERIC_HEADER_CLASS(Root : GENERIC_HEADER_CLASS.Locator) is begin case Kind(Root) is when generic_headerKind => Scan_generic_header(Root); when others => null; end case; end Scan_GENERIC_HEADER_CLASS; procedure Scan_generic_header(Root : generic_headerNode.Locator) is as_generic_param_s_List : SeqOfITEM.Generator; as_generic_param_s_Item : ITEM.Locator; use SeqOfITEM; Old_generic_header_IHR : generic_header_IH.RecType := generic_header_IH.R; begin generic_header_IH.R.ih_ingeneric_param := false ; generic_header_IH.R.ih_ingeneric_param := true; if not SeqOfITEM.IsNull(as_generic_param_s(Root)) then StartForward(as_generic_param_s(Root), as_generic_param_s_List); while not Finished(as_generic_param_s_List) loop as_generic_param_s_Item := Cell(as_generic_param_s_List); IncrementToken (semicolonz); Scan_ITEM(as_generic_param_s_Item); Forward(as_generic_param_s_List); end loop; EndIterate(as_generic_param_s_List); end if; generic_header_IH.R.ih_ingeneric_param := true; generic_header_IH.R := Old_generic_header_IHR; end Scan_generic_header; end GENERIC_HEADER_CLASS_Pkg; -- End: SCGENERIC_HEADER_CLASS bdy ----------------------------------------------------- :::::::::::::: scgeneric.spc :::::::::::::: -- Begin: SCGENERIC_HEADER_CLASS spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package GENERIC_HEADER_CLASS_Pkg is procedure Scan_GENERIC_HEADER_CLASS(Root : GENERIC_HEADER_CLASS.Locator); procedure Scan_generic_header(Root : generic_headerNode.Locator); end GENERIC_HEADER_CLASS_Pkg; -- End: SCGENERIC_HEADER_CLASS spc ----------------------------------------------------- :::::::::::::: scheader.bdy :::::::::::::: -- Begin: SCHEADER bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with ITEM_Pkg; use ITEM_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with generic_header_IH; package body HEADER_Pkg is procedure Scan_HEADER(Root : HEADER.Locator) is begin case Kind(Root) is when accept_specKind => Scan_accept_spec(Root); when entry_specKind => Scan_entry_spec(Root); when func_specKind => Scan_func_spec(Root); when proc_specKind => Scan_proc_spec(Root); when others => null; end case; end Scan_HEADER; procedure Scan_accept_spec(Root : accept_specNode.Locator) is as_param_s_List : SeqOfOBJECT_ITEM.Generator; as_param_s_Item : OBJECT_ITEM.Locator; use SeqOfOBJECT_ITEM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (open_parenthesisz); end if; if not NAME_EXP.IsNull(as_family_index(Root)) then IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_family_index(Root)); IncrementToken (closed_parenthesisz); end if; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then StartForward(as_param_s(Root), as_param_s_List); while not Finished(as_param_s_List) loop as_param_s_Item := Cell(as_param_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (semicolonz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_OBJECT_ITEM(as_param_s_Item); Forward(as_param_s_List); end loop; EndIterate(as_param_s_List); if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_accept_spec; procedure Scan_entry_spec(Root : entry_specNode.Locator) is as_param_s_List : SeqOfOBJECT_ITEM.Generator; as_param_s_Item : OBJECT_ITEM.Locator; use SeqOfOBJECT_ITEM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (open_parenthesisz); end if; if not OBJECT_TYPE.IsNull(as_family_range_void(Root)) then IncrementToken (open_parenthesisz); Scan_OBJECT_TYPE(as_family_range_void(Root)); IncrementToken (closed_parenthesisz); end if; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then StartForward(as_param_s(Root), as_param_s_List); while not Finished(as_param_s_List) loop as_param_s_Item := Cell(as_param_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (semicolonz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_OBJECT_ITEM(as_param_s_Item); Forward(as_param_s_List); end loop; EndIterate(as_param_s_List); if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_entry_spec; procedure Scan_func_spec(Root : func_specNode.Locator) is as_param_s_List : SeqOfOBJECT_ITEM.Generator; as_param_s_Item : OBJECT_ITEM.Locator; use SeqOfOBJECT_ITEM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (open_parenthesisz); end if; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then StartForward(as_param_s(Root), as_param_s_List); while not Finished(as_param_s_List) loop as_param_s_Item := Cell(as_param_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (semicolonz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_OBJECT_ITEM(as_param_s_Item); Forward(as_param_s_List); end loop; EndIterate(as_param_s_List); if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; end if; if not object_type_constrainedNode.IsNull(as_return_type(Root)) then IncrementToken (returnz); Scan_object_type_constrained(as_return_type(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_func_spec; procedure Scan_proc_spec(Root : proc_specNode.Locator) is as_param_s_List : SeqOfOBJECT_ITEM.Generator; as_param_s_Item : OBJECT_ITEM.Locator; use SeqOfOBJECT_ITEM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (open_parenthesisz); end if; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then StartForward(as_param_s(Root), as_param_s_List); while not Finished(as_param_s_List) loop as_param_s_Item := Cell(as_param_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (semicolonz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_OBJECT_ITEM(as_param_s_Item); Forward(as_param_s_List); end loop; EndIterate(as_param_s_List); if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_proc_spec; end HEADER_Pkg; -- End: SCHEADER bdy ----------------------------------------------------- :::::::::::::: scheader.spc :::::::::::::: -- Begin: SCHEADER spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package HEADER_Pkg is procedure Scan_HEADER(Root : HEADER.Locator); procedure Scan_accept_spec(Root : accept_specNode.Locator); procedure Scan_entry_spec(Root : entry_specNode.Locator); procedure Scan_func_spec(Root : func_specNode.Locator); procedure Scan_proc_spec(Root : proc_specNode.Locator); end HEADER_Pkg; -- End: SCHEADER spc ----------------------------------------------------- :::::::::::::: scinner_r.bdy :::::::::::::: -- Begin: SCINNER_RECORD_CLASS bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with inner_record_IH; with ITEM_Pkg; use ITEM_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with VARIANT_ALTERNATIVE_CLASS_Pkg; use VARIANT_ALTERNATIVE_CLASS_Pkg; package body INNER_RECORD_CLASS_Pkg is procedure Scan_INNER_RECORD_CLASS(Root : INNER_RECORD_CLASS.Locator) is begin case Kind(Root) is when inner_recordKind => Scan_inner_record(Root); when others => null; end case; end Scan_INNER_RECORD_CLASS; procedure Scan_inner_record(Root : inner_recordNode.Locator) is as_list_List : SeqOfITEM.Generator; as_list_Item : ITEM.Locator; use SeqOfITEM; as_variant_s_List : SeqOfvariant_alternativeNode.Generator; as_variant_s_Item : variant_alternativeNode.Locator; use SeqOfvariant_alternativeNode; as_trailing_pragma_s_List : SeqOfpragma_declNode.Generator; as_trailing_pragma_s_Item : pragma_declNode.Locator; use SeqOfpragma_declNode; Old_inner_record_IHR : inner_record_IH.RecType := inner_record_IH.R; begin inner_record_IH.R.ih_in_variant := false ; if not SeqOfITEM.IsNull(as_list(Root)) then StartForward(as_list(Root), as_list_List); while not Finished(as_list_List) loop as_list_Item := Cell(as_list_List); Scan_ITEM(as_list_Item); Forward(as_list_List); end loop; EndIterate(as_list_List); end if; if not NAME_EXP.IsNull(as_variant_name(Root)) then IncrementToken (case_variantz); inner_record_IH.R.ih_in_variant := true; Scan_NAME_EXP(as_variant_name(Root)); IncrementToken (is_case_variantz); end if; if not SeqOfvariant_alternativeNode.IsNull(as_variant_s(Root)) then StartForward(as_variant_s(Root), as_variant_s_List); while not Finished(as_variant_s_List) loop as_variant_s_Item := Cell(as_variant_s_List); Scan_variant_alternative(as_variant_s_Item); Forward(as_variant_s_List); end loop; EndIterate(as_variant_s_List); IncrementToken (end_case_variantz); IncrementToken (case_variantz); IncrementToken (semicolonz); inner_record_IH.R.ih_in_variant := false; end if; if not SeqOfpragma_declNode.IsNull(as_trailing_pragma_s(Root)) then StartForward(as_trailing_pragma_s(Root), as_trailing_pragma_s_List); while not Finished(as_trailing_pragma_s_List) loop as_trailing_pragma_s_Item := Cell(as_trailing_pragma_s_List); Scan_pragma_decl(as_trailing_pragma_s_Item); Forward(as_trailing_pragma_s_List); end loop; EndIterate(as_trailing_pragma_s_List); end if; inner_record_IH.R := Old_inner_record_IHR; end Scan_inner_record; end INNER_RECORD_CLASS_Pkg; -- End: SCINNER_RECORD_CLASS bdy ----------------------------------------------------- :::::::::::::: scinner_r.spc :::::::::::::: -- Begin: SCINNER_RECORD_CLASS spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package INNER_RECORD_CLASS_Pkg is procedure Scan_INNER_RECORD_CLASS(Root : INNER_RECORD_CLASS.Locator); procedure Scan_inner_record(Root : inner_recordNode.Locator); end INNER_RECORD_CLASS_Pkg; -- End: SCINNER_RECORD_CLASS spc ----------------------------------------------------- :::::::::::::: scitem.bdy :::::::::::::: -- Begin: SCITEM bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with variable_decl_IH; with subtype_decl_IH; with task_decl_IH; with type_decl_IH; with GENERIC_HEADER_CLASS_Pkg; use GENERIC_HEADER_CLASS_Pkg; with DEF_ID_Pkg; use DEF_ID_Pkg; with PKG_DEF_Pkg; use PKG_DEF_Pkg; with HEADER_Pkg; use HEADER_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with OBJECT_DEF_Pkg; use OBJECT_DEF_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with CONSTRAINT_Pkg; use CONSTRAINT_Pkg; with SUBP_DEF_Pkg; use SUBP_DEF_Pkg; with GENERAL_ASSOC_Pkg; use GENERAL_ASSOC_Pkg; with BLOCK_STUB_Pkg; use BLOCK_STUB_Pkg; with TYPE_SPEC_Pkg; use TYPE_SPEC_Pkg; with variable_decl_IH; with type_decl_IH; with generic_header_IH; package body ITEM_Pkg is procedure Scan_ITEM(Root : ITEM.Locator) is begin case Kind(Root) is when GENERIC_ITEMKind => Scan_GENERIC_ITEM(Root); when OBJECT_ITEMKind => Scan_OBJECT_ITEM(Root); when PKG_ITEMKind => Scan_PKG_ITEM(Root); when REP_SPECKind => Scan_REP_SPEC(Root); when SUBP_ITEMKind => Scan_SUBP_ITEM(Root); when entry_declKind => Scan_entry_decl(Root); when exception_declKind => Scan_exception_decl(Root); when null_componentKind => Scan_null_component(Root); when number_declKind => Scan_number_decl(Root); when pragma_declKind => Scan_pragma_decl(Root); when subtype_declKind => Scan_subtype_decl(Root); when subunitKind => Scan_subunit(Root); when task_bodyKind => Scan_task_body(Root); when task_declKind => Scan_task_decl(Root); when type_declKind => Scan_type_decl(Root); when use_clauseKind => Scan_use_clause(Root); when with_clauseKind => Scan_with_clause(Root); when others => null; end case; end Scan_ITEM; procedure Scan_GENERIC_ITEM(Root : GENERIC_ITEM.Locator) is begin case Kind(Root) is when generic_pkg_declKind => Scan_generic_pkg_decl(Root); when generic_subp_declKind => Scan_generic_subp_decl(Root); when others => null; end case; end Scan_GENERIC_ITEM; procedure Scan_generic_pkg_decl(Root : generic_pkg_declNode.Locator) is begin if not GENERIC_HEADER_CLASS.IsNull(as_generic_spec(Root)) then Scan_GENERIC_HEADER_CLASS(as_generic_spec(Root)); end if; if not DEF_ID.IsNull(as_generic_id(Root)) then if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; SetBlockId (lx_symrep (as_generic_id (root)), package_spec_block, SpcId, LineNumber (lx_srcpos (root)) ); IncrementToken (genericz); IncrementToken (package_spcz); IncrementToken (is_package_spcz); IncrementToken (end_package_spcz); IncrementToken (semicolonz); Scan_DEF_ID(as_generic_id(Root)); end if; if not pkg_specNode.IsNull(as_generic_pkg_spec(Root)) then Scan_pkg_spec(as_generic_pkg_spec(Root)); end if; end Scan_generic_pkg_decl; procedure Scan_generic_subp_decl(Root : generic_subp_declNode.Locator) is begin if not GENERIC_HEADER_CLASS.IsNull(as_generic_spec(Root)) then Scan_GENERIC_HEADER_CLASS(as_generic_spec(Root)); end if; if not DEF_ID.IsNull(as_generic_id(Root)) then IncrementToken (genericz); if Kind (as_generic_id (root)) in generic_proc_idKind then IncrementToken (procedurez); else IncrementToken (functionz); end if; Scan_DEF_ID(as_generic_id(Root)); end if; if not HEADER.IsNull(as_generic_subp_spec(Root)) then Scan_HEADER(as_generic_subp_spec(Root)); end if; IncrementToken (semicolonz); end Scan_generic_subp_decl; procedure Scan_OBJECT_ITEM(Root : OBJECT_ITEM.Locator) is begin case Kind(Root) is when component_declKind => Scan_component_decl(Root); when constant_declKind => Scan_constant_decl(Root); when dscrmt_declKind => Scan_dscrmt_decl(Root); when in_declKind => Scan_in_decl(Root); when in_out_declKind => Scan_in_out_decl(Root); when out_declKind => Scan_out_decl(Root); when variable_declKind => Scan_variable_decl(Root); when others => null; end case; end Scan_OBJECT_ITEM; procedure Scan_component_decl(Root : component_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; IncrementToken (semicolonz); SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_component_decl; procedure Scan_constant_decl(Root : constant_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then IncrementToken (constantz); Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; IncrementToken (semicolonz); SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_constant_decl; procedure Scan_dscrmt_decl(Root : dscrmt_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_dscrmt_decl; procedure Scan_in_decl(Root : in_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then if lx_explicit_in_decl (root) then IncrementToken (in_parameterz); end if; Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_in_decl; procedure Scan_in_out_decl(Root : in_out_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then IncrementToken (in_out_parameterz); Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_in_out_decl; procedure Scan_out_decl(Root : out_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then IncrementToken (outz); Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_out_decl; procedure Scan_variable_decl(Root : variable_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_variable_decl_IHR : variable_decl_IH.RecType := variable_decl_IH.R; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin variable_decl_IH.R.ih_init := false ; SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; IncrementToken (semicolonz); variable_decl_IH.R := Old_variable_decl_IHR; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_variable_decl; procedure Scan_PKG_ITEM(Root : PKG_ITEM.Locator) is begin case Kind(Root) is when pkg_bodyKind => Scan_pkg_body(Root); when pkg_declKind => Scan_pkg_decl(Root); when others => null; end case; end Scan_PKG_ITEM; procedure Scan_pkg_body(Root : pkg_bodyNode.Locator) is begin if not pkg_idNode.IsNull(as_pkg_id(Root)) then Scan_pkg_id(as_pkg_id(Root)); if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; SetBlockId (lx_symrep (as_pkg_id (root)), package_body_block, BdyId, LineNumber (lx_srcpos (root)) ); IncrementToken (package_bdyz); IncrementToken (body_packagez); IncrementToken (is_package_bdyz); end if; if not PKG_DEF.IsNull(as_pkg_def(Root)) then Scan_PKG_DEF(as_pkg_def(Root)); end if; if Kind (as_pkg_def (root)) not in pkg_instantiationKind then IncrementToken (semicolonz); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); end if; end Scan_pkg_body; procedure Scan_pkg_decl(Root : pkg_declNode.Locator) is begin if not pkg_idNode.IsNull(as_pkg_id(Root)) then Scan_pkg_id(as_pkg_id(Root)); if Kind (as_pkg_def (root)) not in pkg_instantiationKind then if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; SetBlockId (lx_symrep (as_pkg_id (root)), package_spec_block, SpcId, LineNumber (lx_srcpos (root)) ); IncrementToken (end_package_spcz); end if; IncrementToken (package_spcz); IncrementToken (is_package_spcz); end if; if not PKG_DEF.IsNull(as_pkg_def(Root)) then Scan_PKG_DEF(as_pkg_def(Root)); end if; if Kind (as_pkg_def (root)) not in pkg_instantiationKind then IncrementToken (semicolonz); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); end if; end Scan_pkg_decl; procedure Scan_REP_SPEC(Root : REP_SPEC.Locator) is begin case Kind(Root) is when address_repKind => Scan_address_rep(Root); when record_repKind => Scan_record_rep(Root); when rep_componentKind => Scan_rep_component(Root); when simple_repKind => Scan_simple_rep(Root); when others => null; end case; end Scan_REP_SPEC; procedure Scan_address_rep(Root : address_repNode.Locator) is begin if not NAME_EXP.IsNull(as_rep_name(Root)) then IncrementToken (for_repz); Scan_NAME_EXP(as_rep_name(Root)); IncrementToken (use_repz); IncrementToken (atz); IncrementToken (semicolonz); end if; if not NAME_EXP.IsNull(as_address_rep_exp(Root)) then Scan_NAME_EXP(as_address_rep_exp(Root)); end if; end Scan_address_rep; procedure Scan_record_rep(Root : record_repNode.Locator) is as_components_List : SeqOfrep_componentNode.Generator; as_components_Item : rep_componentNode.Locator; use SeqOfrep_componentNode; begin if not NAME_EXP.IsNull(as_rep_name(Root)) then IncrementToken (for_repz); Scan_NAME_EXP(as_rep_name(Root)); IncrementToken (use_repz); IncrementToken (record_repz); end if; if not NAME_EXP.IsNull(as_record_alignment(Root)) then IncrementToken (atz); IncrementToken (modz); Scan_NAME_EXP(as_record_alignment(Root)); end if; if not SeqOfrep_componentNode.IsNull(as_components(Root)) then StartForward(as_components(Root), as_components_List); while not Finished(as_components_List) loop as_components_Item := Cell(as_components_List); Scan_rep_component(as_components_Item); Forward(as_components_List); end loop; EndIterate(as_components_List); IncrementToken (end_record_repz); IncrementToken (record_repz); IncrementToken (semicolonz); end if; end Scan_record_rep; procedure Scan_rep_component(Root : rep_componentNode.Locator) is begin if not NAME_EXP.IsNull(as_rep_name(Root)) then Scan_NAME_EXP(as_rep_name(Root)); IncrementToken (atz); end if; if not RANGE_CONSTRAINT_CLASS.IsNull(as_alignment_range(Root)) then IncrementToken (rangez); Scan_RANGE_CONSTRAINT_CLASS(as_alignment_range(Root)); end if; if not NAME_EXP.IsNull(as_rep_component_exp(Root)) then Scan_NAME_EXP(as_rep_component_exp(Root)); end if; end Scan_rep_component; procedure Scan_simple_rep(Root : simple_repNode.Locator) is begin if not NAME_EXP.IsNull(as_rep_name(Root)) then Scan_NAME_EXP(as_rep_name(Root)); end if; if not NAME_EXP.IsNull(as_simple_rep_exp(Root)) then IncrementToken (for_repz); Scan_NAME_EXP(as_simple_rep_exp(Root)); IncrementToken (use_repz); end if; end Scan_simple_rep; procedure Scan_SUBP_ITEM(Root : SUBP_ITEM.Locator) is begin case Kind(Root) is when subp_bodyKind => Scan_subp_body(Root); when subp_declKind => Scan_subp_decl(Root); when others => null; end case; end Scan_SUBP_ITEM; procedure Scan_subp_body(Root : subp_bodyNode.Locator) is begin if not DEF_ID.IsNull(as_subp_designator(Root)) then Scan_DEF_ID(as_subp_designator(Root)); if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; if Kind (as_subp_designator (root)) in proc_idKind then SetBlockId (lx_symrep (as_subp_designator (root)), procedure_block, BdyId, LineNumber (lx_srcpos (root)) ); IncrementToken (procedurez); IncrementToken (is_procedurez); else SetBlockId (lx_symrep (as_subp_designator (root)), function_block, BdyId, LineNumber (lx_srcpos (root)) ); IncrementToken (functionz); IncrementToken (is_functionz); end if; end if; if not HEADER.IsNull(as_subp_spec(Root)) then Scan_HEADER(as_subp_spec(Root)); end if; if not SUBP_DEF.IsNull(as_subp_def(Root)) then Scan_SUBP_DEF(as_subp_def(Root)); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); end if; end Scan_subp_body; procedure Scan_subp_decl(Root : subp_declNode.Locator) is begin if not DEF_ID.IsNull(as_subp_designator(Root)) then Scan_DEF_ID(as_subp_designator(Root)); end if; if not HEADER.IsNull(as_subp_spec(Root)) then Scan_HEADER(as_subp_spec(Root)); end if; if not SUBP_DEF.IsNull(as_subp_def(Root)) then Scan_SUBP_DEF(as_subp_def(Root)); end if; if generic_header_IH.R.ih_ingeneric_param then IncrementToken (with_genericz); end if; if Kind (as_subp_designator (root)) in proc_idKind then IncrementToken (procedurez); else IncrementToken (functionz); end if; IncrementToken (semicolonz); end Scan_subp_decl; procedure Scan_entry_decl(Root : entry_declNode.Locator) is begin IncrementToken (entryz); if not entry_idNode.IsNull(as_entry_designator(Root)) then Scan_entry_id(as_entry_designator(Root)); end if; if not entry_specNode.IsNull(as_entry_spec(Root)) then Scan_entry_spec(as_entry_spec(Root)); end if; IncrementToken (semicolonz); end Scan_entry_decl; procedure Scan_exception_decl(Root : exception_declNode.Locator) is as_exception_id_s_List : SeqOfexception_idNode.Generator; as_exception_id_s_Item : exception_idNode.Locator; use SeqOfexception_idNode; begin if not SeqOfexception_idNode.IsNull(as_exception_id_s(Root)) then StartForward(as_exception_id_s(Root), as_exception_id_s_List); while not Finished(as_exception_id_s_List) loop as_exception_id_s_Item := Cell(as_exception_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_exception_id(as_exception_id_s_Item); Forward(as_exception_id_s_List); end loop; EndIterate(as_exception_id_s_List); IncrementToken (colonz); IncrementToken (exceptionz); IncrementToken (semicolonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not NAME_EXP.IsNull(as_exception_def(Root)) then IncrementToken (renamesz); Scan_NAME_EXP(as_exception_def(Root)); end if; end Scan_exception_decl; procedure Scan_null_component(Root : null_componentNode.Locator) is begin IncrementToken (null_fieldz); IncrementToken (semicolonz); end Scan_null_component; procedure Scan_number_decl(Root : number_declNode.Locator) is as_number_id_s_List : SeqOfnumber_idNode.Generator; as_number_id_s_Item : number_idNode.Locator; use SeqOfnumber_idNode; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfnumber_idNode.IsNull(as_number_id_s(Root)) then StartForward(as_number_id_s(Root), as_number_id_s_List); while not Finished(as_number_id_s_List) loop as_number_id_s_Item := Cell(as_number_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_number_id(as_number_id_s_Item); Forward(as_number_id_s_List); end loop; EndIterate(as_number_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not NAME_EXP.IsNull(as_number_exp(Root)) then IncrementToken (constantz); IncrementToken (colon_equalsz); Scan_NAME_EXP(as_number_exp(Root)); end if; IncrementToken (semicolonz); SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_number_decl; procedure Scan_pragma_decl(Root : pragma_declNode.Locator) is as_pragma_param_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_pragma_param_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; begin IncrementToken (pragmaz); if not used_idNode.IsNull(as_pragma_id(Root)) then Scan_used_id(as_pragma_id(Root)); end if; if not SeqOfGENERAL_ASSOC.IsNull(as_pragma_param_assoc_s(Root)) then IncrementToken (open_parenthesisz); StartForward(as_pragma_param_assoc_s(Root), as_pragma_param_assoc_s_List); while not Finished(as_pragma_param_assoc_s_List) loop as_pragma_param_assoc_s_Item := Cell(as_pragma_param_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_GENERAL_ASSOC(as_pragma_param_assoc_s_Item); Forward(as_pragma_param_assoc_s_List); end loop; EndIterate(as_pragma_param_assoc_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; IncrementToken (semicolonz); end Scan_pragma_decl; procedure Scan_subtype_decl(Root : subtype_declNode.Locator) is Old_subtype_decl_IHR : subtype_decl_IH.RecType := subtype_decl_IH.R; begin subtype_decl_IH.R.ih_in_subtype_decl := false ; IncrementToken (subtypez); subtype_decl_IH.R.ih_in_subtype_decl := true; if not subtype_idNode.IsNull(as_subtype_id(Root)) then Scan_subtype_id(as_subtype_id(Root)); IncrementToken (is_subtypez); end if; if not object_type_constrainedNode.IsNull(as_subtype_constrained(Root)) then Scan_object_type_constrained(as_subtype_constrained(Root)); end if; subtype_decl_IH.R.ih_in_subtype_decl := false; IncrementToken (semicolonz); subtype_decl_IH.R := Old_subtype_decl_IHR; end Scan_subtype_decl; procedure Scan_subunit(Root : subunitNode.Locator) is begin IncrementToken (separatez); if not NAME_EXP.IsNull(as_subunit_path(Root)) then IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_subunit_path(Root)); IncrementToken (closed_parenthesisz); end if; if not ITEM.IsNull(as_subunit_body(Root)) then Scan_ITEM(as_subunit_body(Root)); end if; end Scan_subunit; procedure Scan_task_body(Root : task_bodyNode.Locator) is begin if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; SetBlockId (lx_symrep (as_task_body_id (root)), task_body_block, BdyId, LineNumber (lx_srcpos (root)) ); IncrementToken (task_bdyz); IncrementToken (body_taskz); IncrementToken (is_task_bdyz); if not task_body_idNode.IsNull(as_task_body_id(Root)) then Scan_task_body_id(as_task_body_id(Root)); end if; if not BLOCK_STUB.IsNull(as_task_body_block_stub(Root)) then Scan_BLOCK_STUB(as_task_body_block_stub(Root)); end if; IncrementToken (semicolonz); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); end Scan_task_body; procedure Scan_task_decl(Root : task_declNode.Locator) is Old_task_decl_IHR : task_decl_IH.RecType := task_decl_IH.R; begin task_decl_IH.R.ih_intask_decl := false ; task_decl_IH.R.ih_intask_decl := true; if not variable_idNode.IsNull(as_task_id(Root)) then Scan_variable_id(as_task_id(Root)); end if; if not task_specNode.IsNull(as_task_def(Root)) then Scan_task_spec(as_task_def(Root)); end if; task_decl_IH.R.ih_intask_decl := false; task_decl_IH.R := Old_task_decl_IHR; end Scan_task_decl; procedure Scan_type_decl(Root : type_declNode.Locator) is as_type_dscrmt_s_List : SeqOfdscrmt_declNode.Generator; as_type_dscrmt_s_Item : dscrmt_declNode.Locator; use SeqOfdscrmt_declNode; Old_type_decl_IHR : type_decl_IH.RecType := type_decl_IH.R; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if Kind (as_type_spec (root)) not in task_specKind then IncrementToken (typez); IncrementToken (is_typez); end if; if not type_idNode.IsNull(as_type_id(Root)) then Scan_type_id(as_type_id(Root)); end if; if not SeqOfdscrmt_declNode.IsNull(as_type_dscrmt_s(Root)) then IncrementToken (open_parenthesisz); StartForward(as_type_dscrmt_s(Root), as_type_dscrmt_s_List); while not Finished(as_type_dscrmt_s_List) loop as_type_dscrmt_s_Item := Cell(as_type_dscrmt_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (semicolonz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_dscrmt_decl(as_type_dscrmt_s_Item); Forward(as_type_dscrmt_s_List); end loop; EndIterate(as_type_dscrmt_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not TYPE_SPEC.IsNull(as_type_spec(Root)) then Scan_TYPE_SPEC(as_type_spec(Root)); end if; if Kind (as_type_spec (root)) not in task_specKind then IncrementToken (semicolonz); end if; type_decl_IH.R := Old_type_decl_IHR; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_type_decl; procedure Scan_use_clause(Root : use_clauseNode.Locator) is as_use_clause_list_List : SeqOfNAME_EXP.Generator; as_use_clause_list_Item : NAME_EXP.Locator; use SeqOfNAME_EXP; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfNAME_EXP.IsNull(as_use_clause_list(Root)) then IncrementToken (use_contextz); StartForward(as_use_clause_list(Root), as_use_clause_list_List); while not Finished(as_use_clause_list_List) loop as_use_clause_list_Item := Cell(as_use_clause_list_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_NAME_EXP(as_use_clause_list_Item); Forward(as_use_clause_list_List); end loop; EndIterate(as_use_clause_list_List); end if; IncrementToken (semicolonz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_use_clause; procedure Scan_with_clause(Root : with_clauseNode.Locator) is as_with_clause_list_List : SeqOfNAME_EXP.Generator; as_with_clause_list_Item : NAME_EXP.Locator; use SeqOfNAME_EXP; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfNAME_EXP.IsNull(as_with_clause_list(Root)) then IncrementToken (with_contextz); StartForward(as_with_clause_list(Root), as_with_clause_list_List); while not Finished(as_with_clause_list_List) loop as_with_clause_list_Item := Cell(as_with_clause_list_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_NAME_EXP(as_with_clause_list_Item); Forward(as_with_clause_list_List); end loop; EndIterate(as_with_clause_list_List); end if; IncrementToken (semicolonz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_with_clause; end ITEM_Pkg; -- End: SCITEM bdy ----------------------------------------------------- :::::::::::::: scitem.spc :::::::::::::: -- Begin: SCITEM spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package ITEM_Pkg is procedure Scan_ITEM(Root : ITEM.Locator); procedure Scan_GENERIC_ITEM(Root : GENERIC_ITEM.Locator); procedure Scan_generic_pkg_decl(Root : generic_pkg_declNode.Locator); procedure Scan_generic_subp_decl(Root : generic_subp_declNode.Locator); procedure Scan_OBJECT_ITEM(Root : OBJECT_ITEM.Locator); procedure Scan_component_decl(Root : component_declNode.Locator); procedure Scan_constant_decl(Root : constant_declNode.Locator); procedure Scan_dscrmt_decl(Root : dscrmt_declNode.Locator); procedure Scan_in_decl(Root : in_declNode.Locator); procedure Scan_in_out_decl(Root : in_out_declNode.Locator); procedure Scan_out_decl(Root : out_declNode.Locator); procedure Scan_variable_decl(Root : variable_declNode.Locator); procedure Scan_PKG_ITEM(Root : PKG_ITEM.Locator); procedure Scan_pkg_body(Root : pkg_bodyNode.Locator); procedure Scan_pkg_decl(Root : pkg_declNode.Locator); procedure Scan_REP_SPEC(Root : REP_SPEC.Locator); procedure Scan_address_rep(Root : address_repNode.Locator); procedure Scan_record_rep(Root : record_repNode.Locator); procedure Scan_rep_component(Root : rep_componentNode.Locator); procedure Scan_simple_rep(Root : simple_repNode.Locator); procedure Scan_SUBP_ITEM(Root : SUBP_ITEM.Locator); procedure Scan_subp_body(Root : subp_bodyNode.Locator); procedure Scan_subp_decl(Root : subp_declNode.Locator); procedure Scan_entry_decl(Root : entry_declNode.Locator); procedure Scan_exception_decl(Root : exception_declNode.Locator); procedure Scan_null_component(Root : null_componentNode.Locator); procedure Scan_number_decl(Root : number_declNode.Locator); procedure Scan_pragma_decl(Root : pragma_declNode.Locator); procedure Scan_subtype_decl(Root : subtype_declNode.Locator); procedure Scan_subunit(Root : subunitNode.Locator); procedure Scan_task_body(Root : task_bodyNode.Locator); procedure Scan_task_decl(Root : task_declNode.Locator); procedure Scan_type_decl(Root : type_declNode.Locator); procedure Scan_use_clause(Root : use_clauseNode.Locator); procedure Scan_with_clause(Root : with_clauseNode.Locator); end ITEM_Pkg; -- End: SCITEM spc ----------------------------------------------------- :::::::::::::: sciterati.bdy :::::::::::::: -- Begin: SCITERATION bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with DEF_ID_Pkg; use DEF_ID_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; package body ITERATION_Pkg is procedure Scan_ITERATION(Root : ITERATION.Locator) is begin case Kind(Root) is when FOR_ITERATIONKind => Scan_FOR_ITERATION(Root); when while_iterationKind => Scan_while_iteration(Root); when others => null; end case; end Scan_ITERATION; procedure Scan_FOR_ITERATION(Root : FOR_ITERATION.Locator) is begin case Kind(Root) is when forward_iterationKind => Scan_forward_iteration(Root); when reverse_iterationKind => Scan_reverse_iteration(Root); when others => null; end case; end Scan_FOR_ITERATION; procedure Scan_forward_iteration(Root : forward_iterationNode.Locator) is begin if not iteration_idNode.IsNull(as_id(Root)) then IncrementToken (for_loopz); IncrementToken (in_loopz); Scan_iteration_id(as_id(Root)); end if; if not OBJECT_TYPE.IsNull(as_discrete_range(Root)) then Scan_OBJECT_TYPE(as_discrete_range(Root)); end if; end Scan_forward_iteration; procedure Scan_reverse_iteration(Root : reverse_iterationNode.Locator) is begin if not iteration_idNode.IsNull(as_id(Root)) then IncrementToken (for_loopz); IncrementToken (in_loopz); Scan_iteration_id(as_id(Root)); end if; if not OBJECT_TYPE.IsNull(as_discrete_range(Root)) then IncrementToken (reversez); Scan_OBJECT_TYPE(as_discrete_range(Root)); end if; end Scan_reverse_iteration; procedure Scan_while_iteration(Root : while_iterationNode.Locator) is begin if not NAME_EXP.IsNull(as_while_exp(Root)) then IncrementToken (whilez); Scan_NAME_EXP(as_while_exp(Root)); end if; end Scan_while_iteration; end ITERATION_Pkg; -- End: SCITERATION bdy ----------------------------------------------------- :::::::::::::: sciterati.spc :::::::::::::: -- Begin: SCITERATION spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package ITERATION_Pkg is procedure Scan_ITERATION(Root : ITERATION.Locator); procedure Scan_FOR_ITERATION(Root : FOR_ITERATION.Locator); procedure Scan_forward_iteration(Root : forward_iterationNode.Locator); procedure Scan_reverse_iteration(Root : reverse_iterationNode.Locator); procedure Scan_while_iteration(Root : while_iterationNode.Locator); end ITERATION_Pkg; -- End: SCITERATION spc ----------------------------------------------------- :::::::::::::: scname_ex.bdy :::::::::::::: -- Begin: SCNAME_EXP bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with AGG_COMPONENT_Pkg; use AGG_COMPONENT_Pkg; with GENERAL_ASSOC_Pkg; use GENERAL_ASSOC_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with VmmTextPkg; with TEXT_IO; package body NAME_EXP_Pkg is procedure Scan_NAME_EXP(Root : NAME_EXP.Locator) is begin case Kind(Root) is when AGGKind => Scan_AGG(Root); when ALL_COMPONENTSKind => Scan_ALL_COMPONENTS(Root); when CALLSKind => Scan_CALLS(Root); when MARKKind => Scan_MARK(Root); when MEMBERSHIP_EXPKind => Scan_MEMBERSHIP_EXP(Root); when OPERATOR_EXPKind => Scan_OPERATOR_EXP(Root); when SHORT_CIRCUIT_EXPKind => Scan_SHORT_CIRCUIT_EXP(Root); when attributeKind => Scan_attribute(Root); when attribute_indexedKind => Scan_attribute_indexed(Root); when conversionKind => Scan_conversion(Root); when family_indexedKind => Scan_family_indexed(Root); when indexedKind => Scan_indexed(Root); when init_allocatorKind => Scan_init_allocator(Root); when null_accessKind => Scan_null_access(Root); when numeric_literalKind => Scan_numeric_literal(Root); when parenthesizedKind => Scan_parenthesized(Root); when qualifiedKind => Scan_qualified(Root); when sliceKind => Scan_slice(Root); when string_literalKind => Scan_string_literal(Root); when uninit_allocatorKind => Scan_uninit_allocator(Root); when others => null; end case; end Scan_NAME_EXP; procedure Scan_AGG(Root : AGG.Locator) is begin case Kind(Root) is when apply_aggKind => Scan_apply_agg(Root); when array_aggKind => Scan_array_agg(Root); when record_aggKind => Scan_record_agg(Root); when others => null; end case; end Scan_AGG; procedure Scan_apply_agg(Root : apply_aggNode.Locator) is as_agg_s_List : SeqOfAGG_COMPONENT.Generator; as_agg_s_Item : AGG_COMPONENT.Locator; use SeqOfAGG_COMPONENT; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); StartForward(as_agg_s(Root), as_agg_s_List); while not Finished(as_agg_s_List) loop as_agg_s_Item := Cell(as_agg_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_AGG_COMPONENT(as_agg_s_Item); Forward(as_agg_s_List); end loop; EndIterate(as_agg_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_apply_agg; procedure Scan_array_agg(Root : array_aggNode.Locator) is as_agg_s_List : SeqOfAGG_COMPONENT.Generator; as_agg_s_Item : AGG_COMPONENT.Locator; use SeqOfAGG_COMPONENT; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); StartForward(as_agg_s(Root), as_agg_s_List); while not Finished(as_agg_s_List) loop as_agg_s_Item := Cell(as_agg_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_AGG_COMPONENT(as_agg_s_Item); Forward(as_agg_s_List); end loop; EndIterate(as_agg_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_array_agg; procedure Scan_record_agg(Root : record_aggNode.Locator) is as_agg_s_List : SeqOfAGG_COMPONENT.Generator; as_agg_s_Item : AGG_COMPONENT.Locator; use SeqOfAGG_COMPONENT; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); StartForward(as_agg_s(Root), as_agg_s_List); while not Finished(as_agg_s_List) loop as_agg_s_Item := Cell(as_agg_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_AGG_COMPONENT(as_agg_s_Item); Forward(as_agg_s_List); end loop; EndIterate(as_agg_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_record_agg; procedure Scan_ALL_COMPONENTS(Root : ALL_COMPONENTS.Locator) is begin case Kind(Root) is when explicit_all_componentsKind => Scan_explicit_all_components(Root); when implicit_all_componentsKind => Scan_implicit_all_components(Root); when others => null; end case; end Scan_ALL_COMPONENTS; procedure Scan_explicit_all_components(Root : explicit_all_componentsNode.Locator) is begin if not NAME_EXP.IsNull(as_all_name(Root)) then Scan_NAME_EXP(as_all_name(Root)); end if; IncrementToken (allz); IncrementToken (dotz); end Scan_explicit_all_components; procedure Scan_implicit_all_components(Root : implicit_all_componentsNode.Locator) is begin if not NAME_EXP.IsNull(as_all_name(Root)) then Scan_NAME_EXP(as_all_name(Root)); end if; end Scan_implicit_all_components; procedure Scan_CALLS(Root : CALLS.Locator) is begin case Kind(Root) is when apply_callKind => Scan_apply_call(Root); when entry_callKind => Scan_entry_call(Root); when func_callKind => Scan_func_call(Root); when proc_callKind => Scan_proc_call(Root); when others => null; end case; end Scan_CALLS; procedure Scan_apply_call(Root : apply_callNode.Locator) is as_param_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_param_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_apply_name(Root)) then Scan_NAME_EXP(as_apply_name(Root)); if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then IncrementToken (open_parenthesisz); end if; end if; if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then StartForward(as_param_assoc_s(Root), as_param_assoc_s_List); while not Finished(as_param_assoc_s_List) loop as_param_assoc_s_Item := Cell(as_param_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_GENERAL_ASSOC(as_param_assoc_s_Item); Forward(as_param_assoc_s_List); end loop; EndIterate(as_param_assoc_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_apply_call; procedure Scan_entry_call(Root : entry_callNode.Locator) is as_param_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_param_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_apply_name(Root)) then Scan_NAME_EXP(as_apply_name(Root)); if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then IncrementToken (open_parenthesisz); end if; end if; if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then StartForward(as_param_assoc_s(Root), as_param_assoc_s_List); while not Finished(as_param_assoc_s_List) loop as_param_assoc_s_Item := Cell(as_param_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_GENERAL_ASSOC(as_param_assoc_s_Item); Forward(as_param_assoc_s_List); end loop; EndIterate(as_param_assoc_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_entry_call; procedure Scan_func_call(Root : func_callNode.Locator) is as_param_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_param_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_apply_name(Root)) then Scan_NAME_EXP(as_apply_name(Root)); if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then IncrementToken (open_parenthesisz); end if; end if; if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then StartForward(as_param_assoc_s(Root), as_param_assoc_s_List); while not Finished(as_param_assoc_s_List) loop as_param_assoc_s_Item := Cell(as_param_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_GENERAL_ASSOC(as_param_assoc_s_Item); Forward(as_param_assoc_s_List); end loop; EndIterate(as_param_assoc_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_func_call; procedure Scan_proc_call(Root : proc_callNode.Locator) is as_param_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_param_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_apply_name(Root)) then Scan_NAME_EXP(as_apply_name(Root)); if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then IncrementToken (open_parenthesisz); end if; end if; if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then StartForward(as_param_assoc_s(Root), as_param_assoc_s_List); while not Finished(as_param_assoc_s_List) loop as_param_assoc_s_Item := Cell(as_param_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_GENERAL_ASSOC(as_param_assoc_s_Item); Forward(as_param_assoc_s_List); end loop; EndIterate(as_param_assoc_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_proc_call; procedure Scan_MARK(Root : MARK.Locator) is begin case Kind(Root) is when USED_SYMBOLKind => Scan_USED_SYMBOL(Root); when selectedKind => Scan_selected(Root); when others => null; end case; end Scan_MARK; procedure Scan_USED_SYMBOL(Root : USED_SYMBOL.Locator) is begin case Kind(Root) is when used_charKind => Scan_used_char(Root); when used_idKind => Scan_used_id(Root); when used_operatorKind => Scan_used_operator(Root); when others => null; end case; end Scan_USED_SYMBOL; procedure Scan_used_char(Root : used_charNode.Locator) is begin Literal_Set.Insert (lx_text (lx_symrep (root)), CurrentBlock.SetOfLiterals); IncrementToken (single_quotez); IncrementToken (single_quotez); end Scan_used_char; procedure Scan_used_id(Root : used_idNode.Locator) is begin if not DEF_ID.IsNull (sm_def (root)) then DEF_ID_Set.Insert (sm_def (root), CurrentBlock.SetOfDEF_IDs); else TEXT_IO.Put ("?? Unexpected null sm_def: "); TEXT_IO.Put_Line ( VmmTextPkg.Value ( Source_Text.Value ( lx_text ( ne_normalized_symrep ( ne_symbol_entry_in_table ( lx_symrep ( root)))))) ); end if; end Scan_used_id; procedure Scan_used_operator(Root : used_operatorNode.Locator) is begin DEF_ID_Set.Insert (sm_def (root), CurrentBlock.SetOfDEF_IDs); end Scan_used_operator; procedure Scan_selected(Root : selectedNode.Locator) is begin if not NAME_EXP.IsNull(as_selected_name(Root)) then Scan_NAME_EXP(as_selected_name(Root)); IncrementToken (dotz); end if; if not NAME_EXP.IsNull(as_selected_designator(Root)) then Scan_NAME_EXP(as_selected_designator(Root)); end if; end Scan_selected; procedure Scan_MEMBERSHIP_EXP(Root : MEMBERSHIP_EXP.Locator) is begin case Kind(Root) is when in_expKind => Scan_in_exp(Root); when not_in_expKind => Scan_not_in_exp(Root); when others => null; end case; end Scan_MEMBERSHIP_EXP; procedure Scan_in_exp(Root : in_expNode.Locator) is begin if not NAME_EXP.IsNull(as_membership_exp(Root)) then Scan_NAME_EXP(as_membership_exp(Root)); IncrementToken (in_membershipz); end if; if not OBJECT_TYPE.IsNull(as_membership_type_range(Root)) then Scan_OBJECT_TYPE(as_membership_type_range(Root)); end if; end Scan_in_exp; procedure Scan_not_in_exp(Root : not_in_expNode.Locator) is begin if not NAME_EXP.IsNull(as_membership_exp(Root)) then Scan_NAME_EXP(as_membership_exp(Root)); IncrementToken (not_in_membershipz); IncrementToken (in_membershipz); end if; if not OBJECT_TYPE.IsNull(as_membership_type_range(Root)) then Scan_OBJECT_TYPE(as_membership_type_range(Root)); end if; end Scan_not_in_exp; procedure Scan_OPERATOR_EXP(Root : OPERATOR_EXP.Locator) is begin case Kind(Root) is when binary_operationKind => Scan_binary_operation(Root); when unary_operationKind => Scan_unary_operation(Root); when others => null; end case; end Scan_OPERATOR_EXP; procedure Scan_binary_operation(Root : binary_operationNode.Locator) is begin if not NAME_EXP.IsNull(as_left_exp(Root)) then Scan_NAME_EXP(as_left_exp(Root)); end if; if not used_operatorNode.IsNull(as_operator(Root)) then Scan_used_operator(as_operator(Root)); end if; if not NAME_EXP.IsNull(as_right_exp(Root)) then Scan_NAME_EXP(as_right_exp(Root)); end if; end Scan_binary_operation; procedure Scan_unary_operation(Root : unary_operationNode.Locator) is begin if not used_operatorNode.IsNull(as_operator(Root)) then Scan_used_operator(as_operator(Root)); end if; if not NAME_EXP.IsNull(as_right_exp(Root)) then Scan_NAME_EXP(as_right_exp(Root)); end if; end Scan_unary_operation; procedure Scan_SHORT_CIRCUIT_EXP(Root : SHORT_CIRCUIT_EXP.Locator) is begin case Kind(Root) is when and_then_expKind => Scan_and_then_exp(Root); when or_else_expKind => Scan_or_else_exp(Root); when others => null; end case; end Scan_SHORT_CIRCUIT_EXP; procedure Scan_and_then_exp(Root : and_then_expNode.Locator) is begin if not NAME_EXP.IsNull(as_short_circuit_exp1(Root)) then Scan_NAME_EXP(as_short_circuit_exp1(Root)); end if; if not NAME_EXP.IsNull(as_short_circuit_exp2(Root)) then Scan_NAME_EXP(as_short_circuit_exp2(Root)); end if; IncrementToken (and_thenz); IncrementToken (then_andz); end Scan_and_then_exp; procedure Scan_or_else_exp(Root : or_else_expNode.Locator) is begin if not NAME_EXP.IsNull(as_short_circuit_exp1(Root)) then Scan_NAME_EXP(as_short_circuit_exp1(Root)); end if; if not NAME_EXP.IsNull(as_short_circuit_exp2(Root)) then Scan_NAME_EXP(as_short_circuit_exp2(Root)); end if; IncrementToken (or_elsez); IncrementToken (else_orz); end Scan_or_else_exp; procedure Scan_attribute(Root : attributeNode.Locator) is begin if not NAME_EXP.IsNull(as_attribute_name(Root)) then Scan_NAME_EXP(as_attribute_name(Root)); IncrementToken (tickz); end if; if not NAME_EXP.IsNull(as_attribute_id(Root)) then Scan_NAME_EXP(as_attribute_id(Root)); end if; end Scan_attribute; procedure Scan_attribute_indexed(Root : attribute_indexedNode.Locator) is begin if not NAME_EXP.IsNull(as_attribute_indexed_name(Root)) then IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_attribute_indexed_name(Root)); IncrementToken (closed_parenthesisz); end if; if not NAME_EXP.IsNull(as_attribute_indexed_exp(Root)) then Scan_NAME_EXP(as_attribute_indexed_exp(Root)); end if; end Scan_attribute_indexed; procedure Scan_conversion(Root : conversionNode.Locator) is begin if not NAME_EXP.IsNull(as_conversion_name(Root)) then IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_conversion_name(Root)); IncrementToken (closed_parenthesisz); end if; if not NAME_EXP.IsNull(as_conversion_exp(Root)) then Scan_NAME_EXP(as_conversion_exp(Root)); end if; end Scan_conversion; procedure Scan_family_indexed(Root : family_indexedNode.Locator) is begin if not NAME_EXP.IsNull(as_family_index(Root)) then IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_family_index(Root)); IncrementToken (closed_parenthesisz); end if; if not NAME_EXP.IsNull(as_family_name(Root)) then Scan_NAME_EXP(as_family_name(Root)); end if; end Scan_family_indexed; procedure Scan_indexed(Root : indexedNode.Locator) is as_indexed_exp_s_List : SeqOfNAME_EXP.Generator; as_indexed_exp_s_Item : NAME_EXP.Locator; use SeqOfNAME_EXP; begin if not NAME_EXP.IsNull(as_indexed_name(Root)) then Scan_NAME_EXP(as_indexed_name(Root)); end if; if not SeqOfNAME_EXP.IsNull(as_indexed_exp_s(Root)) then IncrementToken (open_parenthesisz); StartForward(as_indexed_exp_s(Root), as_indexed_exp_s_List); while not Finished(as_indexed_exp_s_List) loop as_indexed_exp_s_Item := Cell(as_indexed_exp_s_List); Scan_NAME_EXP(as_indexed_exp_s_Item); Forward(as_indexed_exp_s_List); end loop; EndIterate(as_indexed_exp_s_List); IncrementToken (closed_parenthesisz); end if; end Scan_indexed; procedure Scan_init_allocator(Root : init_allocatorNode.Locator) is begin IncrementToken (new_allocatorz); if not qualifiedNode.IsNull(as_allocator_qualified(Root)) then Scan_qualified(as_allocator_qualified(Root)); end if; end Scan_init_allocator; procedure Scan_null_access(Root : null_accessNode.Locator) is begin IncrementToken (null_valuez); end Scan_null_access; procedure Scan_numeric_literal(Root : numeric_literalNode.Locator) is begin Literal_Set.Insert (lx_text (lx_numrep (root)), CurrentBlock.SetOfLiterals); end Scan_numeric_literal; procedure Scan_parenthesized(Root : parenthesizedNode.Locator) is begin IncrementToken (open_parenthesisz); if not NAME_EXP.IsNull(as_parenthesized_exp(Root)) then Scan_NAME_EXP(as_parenthesized_exp(Root)); end if; IncrementToken (closed_parenthesisz); end Scan_parenthesized; procedure Scan_qualified(Root : qualifiedNode.Locator) is begin if not MARK.IsNull(as_qualified_name(Root)) then Scan_MARK(as_qualified_name(Root)); IncrementToken (tickz); end if; if not NAME_EXP.IsNull(as_qualified_exp(Root)) then Scan_NAME_EXP(as_qualified_exp(Root)); end if; end Scan_qualified; procedure Scan_slice(Root : sliceNode.Locator) is begin IncrementToken (open_parenthesisz); IncrementToken (closed_parenthesisz); if not NAME_EXP.IsNull(as_slice_name(Root)) then Scan_NAME_EXP(as_slice_name(Root)); end if; if not OBJECT_TYPE.IsNull(as_slice_discrete_range(Root)) then Scan_OBJECT_TYPE(as_slice_discrete_range(Root)); end if; end Scan_slice; procedure Scan_string_literal(Root : string_literalNode.Locator) is begin IncrementToken (double_quotez); Literal_Set.Insert (lx_text (lx_string_symrep (root)), CurrentBlock.SetOfLiterals); IncrementToken (double_quotez); end Scan_string_literal; procedure Scan_uninit_allocator(Root : uninit_allocatorNode.Locator) is begin IncrementToken (new_allocatorz); if not object_type_constrainedNode.IsNull(as_allocator_constrained(Root)) then Scan_object_type_constrained(as_allocator_constrained(Root)); end if; end Scan_uninit_allocator; end NAME_EXP_Pkg; -- End: SCNAME_EXP bdy ----------------------------------------------------- :::::::::::::: scname_ex.spc :::::::::::::: -- Begin: SCNAME_EXP spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package NAME_EXP_Pkg is procedure Scan_NAME_EXP(Root : NAME_EXP.Locator); procedure Scan_AGG(Root : AGG.Locator); procedure Scan_apply_agg(Root : apply_aggNode.Locator); procedure Scan_array_agg(Root : array_aggNode.Locator); procedure Scan_record_agg(Root : record_aggNode.Locator); procedure Scan_ALL_COMPONENTS(Root : ALL_COMPONENTS.Locator); procedure Scan_explicit_all_components(Root : explicit_all_componentsNode.Locator); procedure Scan_implicit_all_components(Root : implicit_all_componentsNode.Locator); procedure Scan_CALLS(Root : CALLS.Locator); procedure Scan_apply_call(Root : apply_callNode.Locator); procedure Scan_entry_call(Root : entry_callNode.Locator); procedure Scan_func_call(Root : func_callNode.Locator); procedure Scan_proc_call(Root : proc_callNode.Locator); procedure Scan_MARK(Root : MARK.Locator); procedure Scan_USED_SYMBOL(Root : USED_SYMBOL.Locator); procedure Scan_used_char(Root : used_charNode.Locator); procedure Scan_used_id(Root : used_idNode.Locator); procedure Scan_used_operator(Root : used_operatorNode.Locator); procedure Scan_selected(Root : selectedNode.Locator); procedure Scan_MEMBERSHIP_EXP(Root : MEMBERSHIP_EXP.Locator); procedure Scan_in_exp(Root : in_expNode.Locator); procedure Scan_not_in_exp(Root : not_in_expNode.Locator); procedure Scan_OPERATOR_EXP(Root : OPERATOR_EXP.Locator); procedure Scan_binary_operation(Root : binary_operationNode.Locator); procedure Scan_unary_operation(Root : unary_operationNode.Locator); procedure Scan_SHORT_CIRCUIT_EXP(Root : SHORT_CIRCUIT_EXP.Locator); procedure Scan_and_then_exp(Root : and_then_expNode.Locator); procedure Scan_or_else_exp(Root : or_else_expNode.Locator); procedure Scan_attribute(Root : attributeNode.Locator); procedure Scan_attribute_indexed(Root : attribute_indexedNode.Locator); procedure Scan_conversion(Root : conversionNode.Locator); procedure Scan_family_indexed(Root : family_indexedNode.Locator); procedure Scan_indexed(Root : indexedNode.Locator); procedure Scan_init_allocator(Root : init_allocatorNode.Locator); procedure Scan_null_access(Root : null_accessNode.Locator); procedure Scan_numeric_literal(Root : numeric_literalNode.Locator); procedure Scan_parenthesized(Root : parenthesizedNode.Locator); procedure Scan_qualified(Root : qualifiedNode.Locator); procedure Scan_slice(Root : sliceNode.Locator); procedure Scan_string_literal(Root : string_literalNode.Locator); procedure Scan_uninit_allocator(Root : uninit_allocatorNode.Locator); end NAME_EXP_Pkg; -- End: SCNAME_EXP spc ----------------------------------------------------- :::::::::::::: scobject_.bdy :::::::::::::: -- Begin: SCOBJECT_DEF bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with NAME_EXP_Pkg; use NAME_EXP_Pkg; package body OBJECT_DEF_Pkg is procedure Scan_OBJECT_DEF(Root : OBJECT_DEF.Locator) is begin case Kind(Root) is when object_initKind => Scan_object_init(Root); when object_renameKind => Scan_object_rename(Root); when others => null; end case; end Scan_OBJECT_DEF; procedure Scan_object_init(Root : object_initNode.Locator) is begin IncrementToken (colon_equalsz); if not NAME_EXP.IsNull(as_init_exp(Root)) then Scan_NAME_EXP(as_init_exp(Root)); end if; end Scan_object_init; procedure Scan_object_rename(Root : object_renameNode.Locator) is begin IncrementToken (renamesz); if not NAME_EXP.IsNull(as_rename_name(Root)) then Scan_NAME_EXP(as_rename_name(Root)); end if; end Scan_object_rename; end OBJECT_DEF_Pkg; -- End: SCOBJECT_DEF bdy ----------------------------------------------------- :::::::::::::: scobject_.spc :::::::::::::: -- Begin: SCOBJECT_DEF spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package OBJECT_DEF_Pkg is procedure Scan_OBJECT_DEF(Root : OBJECT_DEF.Locator); procedure Scan_object_init(Root : object_initNode.Locator); procedure Scan_object_rename(Root : object_renameNode.Locator); end OBJECT_DEF_Pkg; -- End: SCOBJECT_DEF spc ----------------------------------------------------- :::::::::::::: scpkg_def.bdy :::::::::::::: -- Begin: SCPKG_DEF bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with BLOCK_STUB_Pkg; use BLOCK_STUB_Pkg; with GENERAL_ASSOC_Pkg; use GENERAL_ASSOC_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with ITEM_Pkg; use ITEM_Pkg; package body PKG_DEF_Pkg is procedure Scan_PKG_DEF(Root : PKG_DEF.Locator) is begin case Kind(Root) is when pkg_block_stubKind => Scan_pkg_block_stub(Root); when pkg_instantiationKind => Scan_pkg_instantiation(Root); when pkg_renameKind => Scan_pkg_rename(Root); when pkg_specKind => Scan_pkg_spec(Root); when others => null; end case; end Scan_PKG_DEF; procedure Scan_pkg_block_stub(Root : pkg_block_stubNode.Locator) is begin if not BLOCK_STUB.IsNull(as_pkg_block_stub(Root)) then Scan_BLOCK_STUB(as_pkg_block_stub(Root)); end if; end Scan_pkg_block_stub; procedure Scan_pkg_instantiation(Root : pkg_instantiationNode.Locator) is as_generic_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_generic_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; begin if not SeqOfGENERAL_ASSOC.IsNull(as_generic_assoc_s(Root)) then IncrementToken (open_parenthesisz); StartForward(as_generic_assoc_s(Root), as_generic_assoc_s_List); while not Finished(as_generic_assoc_s_List) loop as_generic_assoc_s_Item := Cell(as_generic_assoc_s_List); Scan_GENERAL_ASSOC(as_generic_assoc_s_Item); Forward(as_generic_assoc_s_List); end loop; EndIterate(as_generic_assoc_s_List); IncrementToken (closed_parenthesisz); end if; if not NAME_EXP.IsNull(as_instantiation_name(Root)) then Scan_NAME_EXP(as_instantiation_name(Root)); IncrementToken (new_generic_instz); end if; end Scan_pkg_instantiation; procedure Scan_pkg_rename(Root : pkg_renameNode.Locator) is begin IncrementToken (renamesz); if not NAME_EXP.IsNull(as_rename_name(Root)) then IncrementToken (renamesz); Scan_NAME_EXP(as_rename_name(Root)); end if; end Scan_pkg_rename; procedure Scan_pkg_spec(Root : pkg_specNode.Locator) is as_visible_part_List : SeqOfITEM.Generator; as_visible_part_Item : ITEM.Locator; use SeqOfITEM; as_priv_part_List : SeqOfITEM.Generator; as_priv_part_Item : ITEM.Locator; use SeqOfITEM; begin if not SeqOfITEM.IsNull(as_visible_part(Root)) then StartForward(as_visible_part(Root), as_visible_part_List); while not Finished(as_visible_part_List) loop as_visible_part_Item := Cell(as_visible_part_List); Scan_ITEM(as_visible_part_Item); Forward(as_visible_part_List); end loop; EndIterate(as_visible_part_List); end if; if not SeqOfITEM.IsNull(as_priv_part(Root)) then IncrementToken (private_sectionz); StartForward(as_priv_part(Root), as_priv_part_List); while not Finished(as_priv_part_List) loop as_priv_part_Item := Cell(as_priv_part_List); Scan_ITEM(as_priv_part_Item); Forward(as_priv_part_List); end loop; EndIterate(as_priv_part_List); end if; end Scan_pkg_spec; end PKG_DEF_Pkg; -- End: SCPKG_DEF bdy ----------------------------------------------------- :::::::::::::: scpkg_def.spc :::::::::::::: -- Begin: SCPKG_DEF spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package PKG_DEF_Pkg is procedure Scan_PKG_DEF(Root : PKG_DEF.Locator); procedure Scan_pkg_block_stub(Root : pkg_block_stubNode.Locator); procedure Scan_pkg_instantiation(Root : pkg_instantiationNode.Locator); procedure Scan_pkg_rename(Root : pkg_renameNode.Locator); procedure Scan_pkg_spec(Root : pkg_specNode.Locator); end PKG_DEF_Pkg; -- End: SCPKG_DEF spc ----------------------------------------------------- :::::::::::::: scstm.bdy :::::::::::::: --VMS file: %nosc.work.tools.halstead.source*(SCSTM.bdy) --UTS file: /nosccomp/byron/_vms//nosc/work/tools/halstead/COMP/SCSTM.bdy -- Begin: SCSTM bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with block_stm_IH; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with HEADER_Pkg; use HEADER_Pkg; with DEF_ID_Pkg; use DEF_ID_Pkg; with BLOCK_STUB_Pkg; use BLOCK_STUB_Pkg; with ALTERNATIVE_Pkg; use ALTERNATIVE_Pkg; with ITERATION_Pkg; use ITERATION_Pkg; with ITEM_Pkg; use ITEM_Pkg; with TEXT_IO; use TEXT_IO; with VmmTextPkg; with Block_Utilities; package body STM_Pkg is procedure Scan_STM(Root : STM.Locator) is begin case Kind(Root) is when CALL_STMKind => Scan_CALL_STM(Root); when SELECTIVE_ENTRY_STMKind => Scan_SELECTIVE_ENTRY_STM(Root); when abort_stmKind => Scan_abort_stm(Root); when accept_stmKind => Scan_accept_stm(Root); when assign_stmKind => Scan_assign_stm(Root); when block_stmKind => Scan_block_stm(Root); when case_stmKind => Scan_case_stm(Root); when code_stmKind => Scan_code_stm(Root); when delay_stmKind => Scan_delay_stm(Root); when exit_stmKind => Scan_exit_stm(Root); when goto_stmKind => Scan_goto_stm(Root); when if_stmKind => Scan_if_stm(Root); when labeled_stmKind => Scan_labeled_stm(Root); when loop_stmKind => Scan_loop_stm(Root); when null_stmKind => Scan_null_stm(Root); when pragma_stmKind => Scan_pragma_stm(Root); when raise_stmKind => Scan_raise_stm(Root); when return_stmKind => Scan_return_stm(Root); when select_stmKind => Scan_select_stm(Root); when terminate_stmKind => Scan_terminate_stm(Root); when others => null; end case; end Scan_STM; procedure Scan_CALL_STM(Root : CALL_STM.Locator) is begin case Kind(Root) is when apply_call_stmKind => Scan_apply_call_stm(Root); when entry_call_stmKind => Scan_entry_call_stm(Root); when proc_call_stmKind => Scan_proc_call_stm(Root); when others => null; end case; end Scan_CALL_STM; procedure Scan_apply_call_stm(Root : apply_call_stmNode.Locator) is begin if not NAME_EXP.IsNull(as_call_name(Root)) then Scan_NAME_EXP(as_call_name(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_apply_call_stm; procedure Scan_entry_call_stm(Root : entry_call_stmNode.Locator) is begin if not NAME_EXP.IsNull(as_call_name(Root)) then Scan_NAME_EXP(as_call_name(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_entry_call_stm; procedure Scan_proc_call_stm(Root : proc_call_stmNode.Locator) is begin if not NAME_EXP.IsNull(as_call_name(Root)) then Scan_NAME_EXP(as_call_name(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_proc_call_stm; procedure Scan_SELECTIVE_ENTRY_STM(Root : SELECTIVE_ENTRY_STM.Locator) is begin case Kind(Root) is when cond_entry_stmKind => Scan_cond_entry_stm(Root); when timed_entry_stmKind => Scan_timed_entry_stm(Root); when others => null; end case; end Scan_SELECTIVE_ENTRY_STM; procedure Scan_cond_entry_stm(Root : cond_entry_stmNode.Locator) is as_sel_entry_stm_s1_List : SeqOfSTM.Generator; as_sel_entry_stm_s1_Item : STM.Locator; use SeqOfSTM; as_sel_entry_stm_s2_List : SeqOfSTM.Generator; as_sel_entry_stm_s2_Item : STM.Locator; use SeqOfSTM; begin if not SeqOfSTM.IsNull(as_sel_entry_stm_s1(Root)) then IncrementToken (selectz); StartForward(as_sel_entry_stm_s1(Root), as_sel_entry_stm_s1_List); while not Finished(as_sel_entry_stm_s1_List) loop as_sel_entry_stm_s1_Item := Cell(as_sel_entry_stm_s1_List); Scan_STM(as_sel_entry_stm_s1_Item); Forward(as_sel_entry_stm_s1_List); end loop; EndIterate(as_sel_entry_stm_s1_List); end if; if not SeqOfSTM.IsNull(as_sel_entry_stm_s2(Root)) then IncrementToken (elsez); StartForward(as_sel_entry_stm_s2(Root), as_sel_entry_stm_s2_List); while not Finished(as_sel_entry_stm_s2_List) loop as_sel_entry_stm_s2_Item := Cell(as_sel_entry_stm_s2_List); Scan_STM(as_sel_entry_stm_s2_Item); Forward(as_sel_entry_stm_s2_List); end loop; EndIterate(as_sel_entry_stm_s2_List); IncrementToken (end_selectz); IncrementToken (selectz); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_cond_entry_stm; procedure Scan_timed_entry_stm(Root : timed_entry_stmNode.Locator) is as_sel_entry_stm_s1_List : SeqOfSTM.Generator; as_sel_entry_stm_s1_Item : STM.Locator; use SeqOfSTM; as_sel_entry_stm_s2_List : SeqOfSTM.Generator; as_sel_entry_stm_s2_Item : STM.Locator; use SeqOfSTM; begin if not SeqOfSTM.IsNull(as_sel_entry_stm_s1(Root)) then IncrementToken (selectz); StartForward(as_sel_entry_stm_s1(Root), as_sel_entry_stm_s1_List); while not Finished(as_sel_entry_stm_s1_List) loop as_sel_entry_stm_s1_Item := Cell(as_sel_entry_stm_s1_List); Scan_STM(as_sel_entry_stm_s1_Item); Forward(as_sel_entry_stm_s1_List); end loop; EndIterate(as_sel_entry_stm_s1_List); end if; if not SeqOfSTM.IsNull(as_sel_entry_stm_s2(Root)) then IncrementToken (or_selectz); StartForward(as_sel_entry_stm_s2(Root), as_sel_entry_stm_s2_List); while not Finished(as_sel_entry_stm_s2_List) loop as_sel_entry_stm_s2_Item := Cell(as_sel_entry_stm_s2_List); Scan_STM(as_sel_entry_stm_s2_Item); Forward(as_sel_entry_stm_s2_List); end loop; EndIterate(as_sel_entry_stm_s2_List); IncrementToken (end_selectz); IncrementToken (selectz); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_timed_entry_stm; procedure Scan_abort_stm(Root : abort_stmNode.Locator) is as_abort_name_s_List : SeqOfNAME_EXP.Generator; as_abort_name_s_Item : NAME_EXP.Locator; use SeqOfNAME_EXP; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (abortz); if not SeqOfNAME_EXP.IsNull(as_abort_name_s(Root)) then StartForward(as_abort_name_s(Root), as_abort_name_s_List); while not Finished(as_abort_name_s_List) loop as_abort_name_s_Item := Cell(as_abort_name_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_NAME_EXP(as_abort_name_s_Item); Forward(as_abort_name_s_List); end loop; EndIterate(as_abort_name_s_List); end if; SERIES_UNIT_IH.R.ih_inlist := false; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_abort_stm; procedure Scan_accept_stm(Root : accept_stmNode.Locator) is as_accept_stm_s_List : SeqOfSTM.Generator; as_accept_stm_s_Item : STM.Locator; use SeqOfSTM; begin IncrementToken (acceptz); if not NAME_EXP.IsNull(as_accept_designator(Root)) then Scan_NAME_EXP(as_accept_designator(Root)); end if; if not accept_specNode.IsNull(as_accept_spec(Root)) then Scan_accept_spec(as_accept_spec(Root)); end if; if not SeqOfSTM.IsNull(as_accept_stm_s(Root)) then IncrementToken (doz); IncrementToken (end_acceptz); StartForward(as_accept_stm_s(Root), as_accept_stm_s_List); while not Finished(as_accept_stm_s_List) loop as_accept_stm_s_Item := Cell(as_accept_stm_s_List); Scan_STM(as_accept_stm_s_Item); Forward(as_accept_stm_s_List); end loop; EndIterate(as_accept_stm_s_List); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_accept_stm; procedure Scan_assign_stm(Root : assign_stmNode.Locator) is begin IncrementToken (colon_equalsz); if not NAME_EXP.IsNull(as_assign_name(Root)) then Scan_NAME_EXP(as_assign_name(Root)); end if; if not NAME_EXP.IsNull(as_assign_exp(Root)) then Scan_NAME_EXP(as_assign_exp(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_assign_stm; procedure Scan_block_stm(Root : block_stmNode.Locator) is Old_block_stm_IHR : block_stm_IH.RecType := block_stm_IH.R; begin block_stm_IH.R.ih_inblock := false ; if not block_idNode.IsNull(as_block_label(Root)) then Scan_block_id(as_block_label(Root)); end if; if not body_blockNode.IsNull(as_block_body(Root)) then if Block_Utilities.In_Declare_Block (as_block_body (root)) then block_stm_IH.R.ih_inblock := true; if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push (BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; if Block_Utilities.Is_Block_Labeled (root) then -- Count : which is associated with the block name -- here. At this point we know we have a label id and -- the colon adds to the complexity of the declare block. SetBlockId ( lx_symrep (as_block_label (root)), declare_block, DecId, LineNumber (lx_srcpos (root)) ); else SetBlockId ( TOKEN.NullRef, declare_block, DecId, LineNumber (lx_srcpos (root)) ); end if; end if; -- This next check is made regardless of whether we are in -- a block_stm with declarations or one without declarations. If -- the block has a name then it has a colon. if Block_Utilities.Is_Block_Labeled (root) then IncrementToken (colonz); end if; Scan_body_block(as_block_body(Root)); end if; if Block_Utilities.In_Declare_Block (as_block_body (root)) then IncrementToken (semicolonz); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); IncrementToken (declare_blockz); end if; block_stm_IH.R.ih_inblock := false; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; block_stm_IH.R := Old_block_stm_IHR; end Scan_block_stm; procedure Scan_case_stm(Root : case_stmNode.Locator) is as_case_alternative_s_List : SeqOfcase_alternativeNode.Generator; as_case_alternative_s_Item : case_alternativeNode.Locator; use SeqOfcase_alternativeNode; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (case_stmz); IncrementToken (case_stmz); IncrementToken (is_case_stmz); IncrementToken (end_case_stmz); if not NAME_EXP.IsNull(as_case_exp(Root)) then Scan_NAME_EXP(as_case_exp(Root)); end if; if not SeqOfcase_alternativeNode.IsNull(as_case_alternative_s(Root)) then StartForward(as_case_alternative_s(Root), as_case_alternative_s_List); while not Finished(as_case_alternative_s_List) loop as_case_alternative_s_Item := Cell(as_case_alternative_s_List); Scan_case_alternative(as_case_alternative_s_Item); Forward(as_case_alternative_s_List); end loop; EndIterate(as_case_alternative_s_List); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_case_stm; procedure Scan_code_stm(Root : code_stmNode.Locator) is begin if not qualifiedNode.IsNull(as_code_exp(Root)) then Scan_qualified(as_code_exp(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_code_stm; procedure Scan_delay_stm(Root : delay_stmNode.Locator) is begin IncrementToken (delayz); if not NAME_EXP.IsNull(as_delay_exp(Root)) then Scan_NAME_EXP(as_delay_exp(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_delay_stm; procedure Scan_exit_stm(Root : exit_stmNode.Locator) is begin IncrementToken (exitz); if not NAME_EXP.IsNull(as_exit_name_void(Root)) then Scan_NAME_EXP(as_exit_name_void(Root)); end if; if not NAME_EXP.IsNull(as_exit_exp_void(Root)) then IncrementToken (when_exitz); Scan_NAME_EXP(as_exit_exp_void(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_exit_stm; procedure Scan_goto_stm(Root : goto_stmNode.Locator) is begin IncrementToken (gotoz); if not NAME_EXP.IsNull(as_goto_name(Root)) then Scan_NAME_EXP(as_goto_name(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_goto_stm; procedure Scan_if_stm(Root : if_stmNode.Locator) is as_if_list_List : SeqOfcond_alternativeNode.Generator; as_if_list_Item : cond_alternativeNode.Locator; use SeqOfcond_alternativeNode; begin IncrementToken (ifz); IncrementToken (ifz); IncrementToken (end_ifz); if not SeqOfcond_alternativeNode.IsNull(as_if_list(Root)) then StartForward(as_if_list(Root), as_if_list_List); while not Finished(as_if_list_List) loop as_if_list_Item := Cell(as_if_list_List); Scan_cond_alternative(as_if_list_Item); Forward(as_if_list_List); end loop; EndIterate(as_if_list_List); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_if_stm; procedure Scan_labeled_stm(Root : labeled_stmNode.Locator) is as_labeled_id_s_List : SeqOflabel_idNode.Generator; as_labeled_id_s_Item : label_idNode.Locator; use SeqOflabel_idNode; begin IncrementToken (open_anglesz); if not SeqOflabel_idNode.IsNull(as_labeled_id_s(Root)) then StartForward(as_labeled_id_s(Root), as_labeled_id_s_List); while not Finished(as_labeled_id_s_List) loop as_labeled_id_s_Item := Cell(as_labeled_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (open_anglesz); IncrementToken (closed_anglesz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_label_id(as_labeled_id_s_Item); Forward(as_labeled_id_s_List); end loop; EndIterate(as_labeled_id_s_List); end if; if not STM.IsNull(as_labeled_stm(Root)) then Scan_STM(as_labeled_stm(Root)); end if; IncrementToken (closed_anglesz); SERIES_UNIT_IH.R.ih_inlist := false; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_labeled_stm; procedure Scan_loop_stm(Root : loop_stmNode.Locator) is as_loop_stm_s_List : SeqOfSTM.Generator; as_loop_stm_s_Item : STM.Locator; use SeqOfSTM; begin IncrementToken (loopz); IncrementToken (loopz); IncrementToken (end_loopz); if not ITERATION.IsNull(as_iteration(Root)) then Scan_ITERATION(as_iteration(Root)); end if; if not loop_idNode.IsNull(as_loop_label(Root)) then Scan_loop_id(as_loop_label(Root)); end if; if not SeqOfSTM.IsNull(as_loop_stm_s(Root)) then StartForward(as_loop_stm_s(Root), as_loop_stm_s_List); while not Finished(as_loop_stm_s_List) loop as_loop_stm_s_Item := Cell(as_loop_stm_s_List); Scan_STM(as_loop_stm_s_Item); Forward(as_loop_stm_s_List); end loop; EndIterate(as_loop_stm_s_List); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_loop_stm; procedure Scan_null_stm(Root : null_stmNode.Locator) is begin IncrementToken (null_stmz); if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_null_stm; procedure Scan_pragma_stm(Root : pragma_stmNode.Locator) is begin if not pragma_declNode.IsNull(as_pragma(Root)) then Scan_pragma_decl(as_pragma(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_pragma_stm; procedure Scan_raise_stm(Root : raise_stmNode.Locator) is begin IncrementToken (raisez); if not NAME_EXP.IsNull(as_raise_name_void(Root)) then Scan_NAME_EXP(as_raise_name_void(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_raise_stm; procedure Scan_return_stm(Root : return_stmNode.Locator) is begin IncrementToken (returnz); if not NAME_EXP.IsNull(as_return_exp_void(Root)) then Scan_NAME_EXP(as_return_exp_void(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_return_stm; procedure Scan_select_stm(Root : select_stmNode.Locator) is as_select_clause_s_List : SeqOfselect_alternativeNode.Generator; as_select_clause_s_Item : select_alternativeNode.Locator; use SeqOfselect_alternativeNode; begin IncrementToken (selectz); IncrementToken (selectz); IncrementToken (end_selectz); if not SeqOfselect_alternativeNode.IsNull(as_select_clause_s(Root)) then StartForward(as_select_clause_s(Root), as_select_clause_s_List); while not Finished(as_select_clause_s_List) loop as_select_clause_s_Item := Cell(as_select_clause_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (or_selectz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_select_alternative(as_select_clause_s_Item); Forward(as_select_clause_s_List); end loop; EndIterate(as_select_clause_s_List); end if; if not cond_alternativeNode.IsNull(as_select_else(Root)) then Scan_cond_alternative(as_select_else(Root)); IncrementToken (elsez); end if; SERIES_UNIT_IH.R.ih_inlist := false; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_select_stm; procedure Scan_terminate_stm(Root : terminate_stmNode.Locator) is begin IncrementToken (terminatez); if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_terminate_stm; end STM_Pkg; -- End: SCSTM bdy ----------------------------------------------------- :::::::::::::: scstm.spc :::::::::::::: -- Begin: SCSTM spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package STM_Pkg is procedure Scan_STM(Root : STM.Locator); procedure Scan_CALL_STM(Root : CALL_STM.Locator); procedure Scan_apply_call_stm(Root : apply_call_stmNode.Locator); procedure Scan_entry_call_stm(Root : entry_call_stmNode.Locator); procedure Scan_proc_call_stm(Root : proc_call_stmNode.Locator); procedure Scan_SELECTIVE_ENTRY_STM(Root : SELECTIVE_ENTRY_STM.Locator); procedure Scan_cond_entry_stm(Root : cond_entry_stmNode.Locator); procedure Scan_timed_entry_stm(Root : timed_entry_stmNode.Locator); procedure Scan_abort_stm(Root : abort_stmNode.Locator); procedure Scan_accept_stm(Root : accept_stmNode.Locator); procedure Scan_assign_stm(Root : assign_stmNode.Locator); procedure Scan_block_stm(Root : block_stmNode.Locator); procedure Scan_case_stm(Root : case_stmNode.Locator); procedure Scan_code_stm(Root : code_stmNode.Locator); procedure Scan_delay_stm(Root : delay_stmNode.Locator); procedure Scan_exit_stm(Root : exit_stmNode.Locator); procedure Scan_goto_stm(Root : goto_stmNode.Locator); procedure Scan_if_stm(Root : if_stmNode.Locator); procedure Scan_labeled_stm(Root : labeled_stmNode.Locator); procedure Scan_loop_stm(Root : loop_stmNode.Locator); procedure Scan_null_stm(Root : null_stmNode.Locator); procedure Scan_pragma_stm(Root : pragma_stmNode.Locator); procedure Scan_raise_stm(Root : raise_stmNode.Locator); procedure Scan_return_stm(Root : return_stmNode.Locator); procedure Scan_select_stm(Root : select_stmNode.Locator); procedure Scan_terminate_stm(Root : terminate_stmNode.Locator); end STM_Pkg; -- End: SCSTM spc ----------------------------------------------------- :::::::::::::: scsubp_de.bdy :::::::::::::: -- Begin: SCSUBP_DEF bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with BLOCK_STUB_Pkg; use BLOCK_STUB_Pkg; with GENERAL_ASSOC_Pkg; use GENERAL_ASSOC_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; package body SUBP_DEF_Pkg is procedure Scan_SUBP_DEF(Root : SUBP_DEF.Locator) is begin case Kind(Root) is when FORMAL_SUBPKind => Scan_FORMAL_SUBP(Root); when subp_block_stubKind => Scan_subp_block_stub(Root); when subp_instantiationKind => Scan_subp_instantiation(Root); when subp_renameKind => Scan_subp_rename(Root); when others => null; end case; end Scan_SUBP_DEF; procedure Scan_FORMAL_SUBP(Root : FORMAL_SUBP.Locator) is begin case Kind(Root) is when formal_subp_boxKind => Scan_formal_subp_box(Root); when formal_subp_nameKind => Scan_formal_subp_name(Root); when others => null; end case; end Scan_FORMAL_SUBP; procedure Scan_formal_subp_box(Root : formal_subp_boxNode.Locator) is begin IncrementToken (box_default_subpz); end Scan_formal_subp_box; procedure Scan_formal_subp_name(Root : formal_subp_nameNode.Locator) is begin IncrementToken (is_procedurez); end Scan_formal_subp_name; procedure Scan_subp_block_stub(Root : subp_block_stubNode.Locator) is begin if not BLOCK_STUB.IsNull(as_subp_block_stub(Root)) then Scan_BLOCK_STUB(as_subp_block_stub(Root)); end if; IncrementToken (semicolonz); end Scan_subp_block_stub; procedure Scan_subp_instantiation(Root : subp_instantiationNode.Locator) is as_generic_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_generic_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; begin if not SeqOfGENERAL_ASSOC.IsNull(as_generic_assoc_s(Root)) then StartForward(as_generic_assoc_s(Root), as_generic_assoc_s_List); while not Finished(as_generic_assoc_s_List) loop as_generic_assoc_s_Item := Cell(as_generic_assoc_s_List); Scan_GENERAL_ASSOC(as_generic_assoc_s_Item); Forward(as_generic_assoc_s_List); end loop; EndIterate(as_generic_assoc_s_List); end if; if not NAME_EXP.IsNull(as_instantiation_name(Root)) then IncrementToken (is_procedurez); IncrementToken (new_generic_instz); IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_instantiation_name(Root)); IncrementToken (closed_parenthesisz); end if; end Scan_subp_instantiation; procedure Scan_subp_rename(Root : subp_renameNode.Locator) is begin IncrementToken (renamesz); if not NAME_EXP.IsNull(as_rename_name(Root)) then Scan_NAME_EXP(as_rename_name(Root)); end if; end Scan_subp_rename; end SUBP_DEF_Pkg; -- End: SCSUBP_DEF bdy ----------------------------------------------------- :::::::::::::: scsubp_de.spc :::::::::::::: -- Begin: SCSUBP_DEF spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package SUBP_DEF_Pkg is procedure Scan_SUBP_DEF(Root : SUBP_DEF.Locator); procedure Scan_FORMAL_SUBP(Root : FORMAL_SUBP.Locator); procedure Scan_formal_subp_box(Root : formal_subp_boxNode.Locator); procedure Scan_formal_subp_name(Root : formal_subp_nameNode.Locator); procedure Scan_subp_block_stub(Root : subp_block_stubNode.Locator); procedure Scan_subp_instantiation(Root : subp_instantiationNode.Locator); procedure Scan_subp_rename(Root : subp_renameNode.Locator); end SUBP_DEF_Pkg; -- End: SCSUBP_DEF spc ----------------------------------------------------- :::::::::::::: sctype_sp.bdy :::::::::::::: -- Begin: SCTYPE_SPEC bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with CONSTRAINT_Pkg; use CONSTRAINT_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with INNER_RECORD_CLASS_Pkg; use INNER_RECORD_CLASS_Pkg; with DEF_ID_Pkg; use DEF_ID_Pkg; with ITEM_Pkg; use ITEM_Pkg; with task_decl_IH; package body TYPE_SPEC_Pkg is procedure Scan_TYPE_SPEC(Root : TYPE_SPEC.Locator) is begin case Kind(Root) is when ARRAY_TYPEKind => Scan_ARRAY_TYPE(Root); when DSCRMT_TYPEKind => Scan_DSCRMT_TYPE(Root); when FORMAL_SCALARKind => Scan_FORMAL_SCALAR(Root); when access_typeKind => Scan_access_type(Root); when derived_typeKind => Scan_derived_type(Root); when enum_typeKind => Scan_enum_type(Root); when fixed_typeKind => Scan_fixed_type(Root); when float_typeKind => Scan_float_type(Root); when integer_typeKind => Scan_integer_type(Root); when task_specKind => Scan_task_spec(Root); when others => null; end case; end Scan_TYPE_SPEC; procedure Scan_ARRAY_TYPE(Root : ARRAY_TYPE.Locator) is begin case Kind(Root) is when constrained_array_typeKind => Scan_constrained_array_type(Root); when unconstrained_array_typeKind => Scan_unconstrained_array_type(Root); when others => null; end case; end Scan_ARRAY_TYPE; procedure Scan_constrained_array_type(Root : constrained_array_typeNode.Locator) is begin IncrementToken (arrayz); if not index_constraintNode.IsNull(as_array_constraint(Root)) then Scan_index_constraint(as_array_constraint(Root)); end if; if not object_type_constrainedNode.IsNull(as_component_constrained(Root)) then IncrementToken (ofz); Scan_object_type_constrained(as_component_constrained(Root)); end if; end Scan_constrained_array_type; procedure Scan_unconstrained_array_type(Root : unconstrained_array_typeNode.Locator) is as_index_list_List : SeqOfobject_type_indexNode.Generator; as_index_list_Item : object_type_indexNode.Locator; use SeqOfobject_type_indexNode; begin IncrementToken (arrayz); if not SeqOfobject_type_indexNode.IsNull(as_index_list(Root)) then IncrementToken (open_parenthesisz); StartForward(as_index_list(Root), as_index_list_List); while not Finished(as_index_list_List) loop as_index_list_Item := Cell(as_index_list_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (box_rangez); IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_object_type_index(as_index_list_Item); Forward(as_index_list_List); end loop; EndIterate(as_index_list_List); IncrementToken (closed_parenthesisz); IncrementToken (box_rangez); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not object_type_constrainedNode.IsNull(as_component_constrained(Root)) then IncrementToken (ofz); Scan_object_type_constrained(as_component_constrained(Root)); end if; end Scan_unconstrained_array_type; procedure Scan_DSCRMT_TYPE(Root : DSCRMT_TYPE.Locator) is begin case Kind(Root) is when PRIV_TYPEKind => Scan_PRIV_TYPE(Root); when record_typeKind => Scan_record_type(Root); when others => null; end case; end Scan_DSCRMT_TYPE; procedure Scan_PRIV_TYPE(Root : PRIV_TYPE.Locator) is begin case Kind(Root) is when FORMAL_PRIVKind => Scan_FORMAL_PRIV(Root); when lim_priv_typeKind => Scan_lim_priv_type(Root); when nonlim_priv_typeKind => Scan_nonlim_priv_type(Root); when others => null; end case; end Scan_PRIV_TYPE; procedure Scan_FORMAL_PRIV(Root : FORMAL_PRIV.Locator) is begin case Kind(Root) is when generic_lim_priv_typeKind => Scan_generic_lim_priv_type(Root); when generic_priv_typeKind => Scan_generic_priv_type(Root); when others => null; end case; end Scan_FORMAL_PRIV; procedure Scan_generic_lim_priv_type(Root : generic_lim_priv_typeNode.Locator) is begin IncrementToken (limitedz); IncrementToken (private_typez); end Scan_generic_lim_priv_type; procedure Scan_generic_priv_type(Root : generic_priv_typeNode.Locator) is begin IncrementToken (private_typez); end Scan_generic_priv_type; procedure Scan_lim_priv_type(Root : lim_priv_typeNode.Locator) is begin IncrementToken (limitedz); IncrementToken (private_typez); end Scan_lim_priv_type; procedure Scan_nonlim_priv_type(Root : nonlim_priv_typeNode.Locator) is begin IncrementToken (private_typez); end Scan_nonlim_priv_type; procedure Scan_record_type(Root : record_typeNode.Locator) is begin IncrementToken (record_typez); if not inner_recordNode.IsNull(as_inner_record(Root)) then Scan_inner_record(as_inner_record(Root)); end if; IncrementToken (end_recordz); IncrementToken (record_typez); end Scan_record_type; procedure Scan_FORMAL_SCALAR(Root : FORMAL_SCALAR.Locator) is begin case Kind(Root) is when formal_discreteKind => Scan_formal_discrete(Root); when formal_fixedKind => Scan_formal_fixed(Root); when formal_floatKind => Scan_formal_float(Root); when formal_integerKind => Scan_formal_integer(Root); when others => null; end case; end Scan_FORMAL_SCALAR; procedure Scan_formal_discrete(Root : formal_discreteNode.Locator) is begin IncrementToken (box_rangez); IncrementToken (open_parenthesisz); IncrementToken (closed_parenthesisz); end Scan_formal_discrete; procedure Scan_formal_fixed(Root : formal_fixedNode.Locator) is begin IncrementToken (box_rangez); IncrementToken (digitsz); end Scan_formal_fixed; procedure Scan_formal_float(Root : formal_floatNode.Locator) is begin IncrementToken (box_rangez); IncrementToken (deltaz); end Scan_formal_float; procedure Scan_formal_integer(Root : formal_integerNode.Locator) is begin IncrementToken (box_rangez); end Scan_formal_integer; procedure Scan_access_type(Root : access_typeNode.Locator) is begin IncrementToken (accessz); if not object_type_constrainedNode.IsNull(as_access_constrained(Root)) then Scan_object_type_constrained(as_access_constrained(Root)); end if; end Scan_access_type; procedure Scan_derived_type(Root : derived_typeNode.Locator) is begin IncrementToken (new_derived_typez); if not object_type_constrainedNode.IsNull(as_parent_constrained(Root)) then Scan_object_type_constrained(as_parent_constrained(Root)); end if; end Scan_derived_type; procedure Scan_enum_type(Root : enum_typeNode.Locator) is as_enumeral_s_List : SeqOfLITERAL_ID.Generator; as_enumeral_s_Item : LITERAL_ID.Locator; use SeqOfLITERAL_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); StartForward(as_enumeral_s(Root), as_enumeral_s_List); while not Finished(as_enumeral_s_List) loop as_enumeral_s_Item := Cell(as_enumeral_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_LITERAL_ID(as_enumeral_s_Item); Forward(as_enumeral_s_List); end loop; EndIterate(as_enumeral_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_enum_type; procedure Scan_fixed_type(Root : fixed_typeNode.Locator) is begin IncrementToken (deltaz); if not fixed_constraintNode.IsNull(as_fixed_constraint(Root)) then Scan_fixed_constraint(as_fixed_constraint(Root)); end if; end Scan_fixed_type; procedure Scan_float_type(Root : float_typeNode.Locator) is begin IncrementToken (digitsz); if not float_constraintNode.IsNull(as_float_constraint(Root)) then Scan_float_constraint(as_float_constraint(Root)); end if; end Scan_float_type; procedure Scan_integer_type(Root : integer_typeNode.Locator) is begin if not RANGE_CONSTRAINT_CLASS.IsNull(as_range_constraint(Root)) then Scan_RANGE_CONSTRAINT_CLASS(as_range_constraint(Root)); end if; end Scan_integer_type; procedure Scan_task_spec(Root : task_specNode.Locator) is as_task_spec_decl_s_List : SeqOfITEM.Generator; as_task_spec_decl_s_Item : ITEM.Locator; use SeqOfITEM; begin if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; SetBlockId (lx_symrep (sm_def_of_type (root)), task_body_block, SpcId, LineNumber (lx_srcpos (root)) ); if not task_decl_IH.R.ih_intask_decl then -- If we are not in a task_decl and we are scanning task_spec -- then we are in a type_decl and the token type appears. IncrementToken (typez); end if; IncrementToken (task_spcz); IncrementToken (is_task_spcz); IncrementToken (end_task_spcz); if not SeqOfITEM.IsNull(as_task_spec_decl_s(Root)) then StartForward(as_task_spec_decl_s(Root), as_task_spec_decl_s_List); while not Finished(as_task_spec_decl_s_List) loop as_task_spec_decl_s_Item := Cell(as_task_spec_decl_s_List); Scan_ITEM(as_task_spec_decl_s_Item); Forward(as_task_spec_decl_s_List); end loop; EndIterate(as_task_spec_decl_s_List); end if; IncrementToken (semicolonz); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); end Scan_task_spec; end TYPE_SPEC_Pkg; -- End: SCTYPE_SPEC bdy ----------------------------------------------------- :::::::::::::: sctype_sp.spc :::::::::::::: -- Begin: SCTYPE_SPEC spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package TYPE_SPEC_Pkg is procedure Scan_TYPE_SPEC(Root : TYPE_SPEC.Locator); procedure Scan_ARRAY_TYPE(Root : ARRAY_TYPE.Locator); procedure Scan_constrained_array_type(Root : constrained_array_typeNode.Locator); procedure Scan_unconstrained_array_type(Root : unconstrained_array_typeNode.Locator); procedure Scan_DSCRMT_TYPE(Root : DSCRMT_TYPE.Locator); procedure Scan_PRIV_TYPE(Root : PRIV_TYPE.Locator); procedure Scan_FORMAL_PRIV(Root : FORMAL_PRIV.Locator); procedure Scan_generic_lim_priv_type(Root : generic_lim_priv_typeNode.Locator); procedure Scan_generic_priv_type(Root : generic_priv_typeNode.Locator); procedure Scan_lim_priv_type(Root : lim_priv_typeNode.Locator); procedure Scan_nonlim_priv_type(Root : nonlim_priv_typeNode.Locator); procedure Scan_record_type(Root : record_typeNode.Locator); procedure Scan_FORMAL_SCALAR(Root : FORMAL_SCALAR.Locator); procedure Scan_formal_discrete(Root : formal_discreteNode.Locator); procedure Scan_formal_fixed(Root : formal_fixedNode.Locator); procedure Scan_formal_float(Root : formal_floatNode.Locator); procedure Scan_formal_integer(Root : formal_integerNode.Locator); procedure Scan_access_type(Root : access_typeNode.Locator); procedure Scan_derived_type(Root : derived_typeNode.Locator); procedure Scan_enum_type(Root : enum_typeNode.Locator); procedure Scan_fixed_type(Root : fixed_typeNode.Locator); procedure Scan_float_type(Root : float_typeNode.Locator); procedure Scan_integer_type(Root : integer_typeNode.Locator); procedure Scan_task_spec(Root : task_specNode.Locator); end TYPE_SPEC_Pkg; -- End: SCTYPE_SPEC spc ----------------------------------------------------- :::::::::::::: scvariant.bdy :::::::::::::: -- Begin: SCVARIANT_ALTERNATIVE_CLASS bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with ITEM_Pkg; use ITEM_Pkg; with CHOICE_Pkg; use CHOICE_Pkg; with INNER_RECORD_CLASS_Pkg; use INNER_RECORD_CLASS_Pkg; package body VARIANT_ALTERNATIVE_CLASS_Pkg is procedure Scan_VARIANT_ALTERNATIVE_CLASS(Root : VARIANT_ALTERNATIVE_CLASS.Locator) is begin case Kind(Root) is when pragma_variantKind => Scan_pragma_variant(Root); when variant_alternativeKind => Scan_variant_alternative(Root); when others => null; end case; end Scan_VARIANT_ALTERNATIVE_CLASS; procedure Scan_pragma_variant(Root : pragma_variantNode.Locator) is begin if not pragma_declNode.IsNull(as_pragma_variant(Root)) then Scan_pragma_decl(as_pragma_variant(Root)); end if; end Scan_pragma_variant; procedure Scan_variant_alternative(Root : variant_alternativeNode.Locator) is as_variant_choice_s_List : SeqOfCHOICE.Generator; as_variant_choice_s_Item : CHOICE.Locator; use SeqOfCHOICE; begin if not SeqOfCHOICE.IsNull(as_variant_choice_s(Root)) then IncrementToken (when_case_variantz); StartForward(as_variant_choice_s(Root), as_variant_choice_s_List); while not Finished(as_variant_choice_s_List) loop as_variant_choice_s_Item := Cell(as_variant_choice_s_List); Scan_CHOICE(as_variant_choice_s_Item); Forward(as_variant_choice_s_List); end loop; EndIterate(as_variant_choice_s_List); IncrementToken (arrowz); end if; if not inner_recordNode.IsNull(as_record(Root)) then Scan_inner_record(as_record(Root)); end if; end Scan_variant_alternative; end VARIANT_ALTERNATIVE_CLASS_Pkg; -- End: SCVARIANT_ALTERNATIVE_CLASS bdy ----------------------------------------------------- :::::::::::::: scvariant.spc :::::::::::::: -- Begin: SCVARIANT_ALTERNATIVE_CLASS spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package VARIANT_ALTERNATIVE_CLASS_Pkg is procedure Scan_VARIANT_ALTERNATIVE_CLASS(Root : VARIANT_ALTERNATIVE_CLASS.Locator); procedure Scan_pragma_variant(Root : pragma_variantNode.Locator); procedure Scan_variant_alternative(Root : variant_alternativeNode.Locator); end VARIANT_ALTERNATIVE_CLASS_Pkg; -- End: SCVARIANT_ALTERNATIVE_CLASS spc ----------------------------------------------------- :::::::::::::: srcutil.bdy :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/SrcUtil.bdy,v $ -- $Revision: 1.3 $ -- $Date: 85/12/15 18:29:03 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.3 $"); package body Source_Position_Utilities is --| OVERVIEW --| This package creates one routine which checks if a --| MLSP.Source_Position is null. This is helpful --| at some points in the program scan to determine which --| tokens the source program contained. --| NOTES --| This routine should be incorporated in Halstead_Data_Base --| when the world is recompiled. -------------------------------------------------------------------------- function Is_Srcpos_Null ( Position :in MLSP.Source_Position ) return boolean is begin return (MLSP."=" (Position.first_location, 0)); end; end Source_Position_Utilities; :::::::::::::: srcutil.spc :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/SrcUtil.spc,v $ -- $Revision: 1.1 $ -- $Date: 85/12/15 17:35:12 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.1 $"); with ML_Source_Position_Pkg; package Source_Position_Utilities is --| OVERVIEW --| This package creates one routine which checks if a --| MLSP.Source_Position is null. This is helpful --| at some points in the program scan to determine which --| tokens the source program contained. --| NOTES --| This routine should be incorporated in Halstead_Data_Base --| when the world is recompiled. package MLSP renames ML_Source_Position_Pkg; -------------------------------------------------------------------------- function Is_Srcpos_Null ( Position :in MLSP.Source_Position ) return boolean; --| OVERVIEW --| This function returns true if the source position passed in --| is null. end Source_Position_Utilities; :::::::::::::: hdb.bdy :::::::::::::: with Count_Types; with Count; with Text_IO; use Text_IO; with Int_IO; use Int_IO; with VmmTextPkg; with Unchecked_Deallocation; package body Halstead_Data_Base is --| OVERVIEW --| This package does all the counting and processing of the information --| for a block. It analyzes all the token information and determines --| the number of unique operators and operands for the block. It --| scans the list of DEF_ID's in the block and determines whether --| each DEF_ID is either an operator or operand. It also scans the --| list of literals and determines the number of different literals --| as well as the number of times each literal on the list has been --| used. The literals are all counted asoperands. --| --| Using the number of unique operands and operators all the Halstead --| Metrics are computed. The metrics are then displayed using the --| procedure PrintInfo. -------------------------------------------------------------------------- -- LOCAL OBJECTS -------------------------------------------------------------------------- package C renames Count; package CT renames Count_Types; BlockKindLength :constant := 9; MaxLineLength :constant := 80; NumberOfMetrics :constant := 17; NumberOfLinesToClearScreen :constant := 8; BlockStrings: array(BlockKind) of string(1..BlockKindLength) := ( "PROCEDURE", "FUNCTION ", "PACKAGE ", "PACKAGE ", "TASK ", "TASK ", -- The following string is used for declare blocks. It is blank -- because of the DecId string in pkg Definitions. " "); --| These are the strings which will be printed out in the output --| for the corresponding block type. StroudNumber :integer range 5..20 := 5; --| This number is used as a constant in the metric calculations. E0 :integer := 3000; --| Number of elementary discriminations between errors. type Real is digits 6; type MetricsRecord is record UniqueOperators :Float; UniqueOperands :Float; Vocabulary :Float; OperatorUsage :Float; OperandUsage :Float; ProgramLength :Float; EstimatedProgramLength :Float; ProgramVolume :Float; PotentialVolume :Float; ProgramLevel :Float; ProgramLevelApprox :Float; IntelligenceContent :Float; ProgrammingEffort :Float; ProgrammingTime :Float; LanguageLevel :Float; NumberOfDeliveredErrors :Float; ApproxNumberOfDeliveredErrors :Float; end record; --| Each field of this record corresponds to one of the 17 --| Halstead metrics. -------------------------------------------------------------------------- -- LOCAL SUBPROGRAMS -------------------------------------------------------------------------- -------------------------------------------------------------------------- procedure Free is new Unchecked_Deallocation (String, StringPtr); -------------------------------------------------------------------------- function SymRepToString ( --| Converts a SymRep to a string SymRep :in symbol_repNode.Locator ) return String is begin if symbol_repNode.IsNull (SymRep) then return ""; else return VmmTextPkg.Value ( Source_Text.Value ( lx_text ( ne_normalized_symrep ( ne_symbol_entry_in_table ( SymRep))))); end if; end SymRepToString; -------------------------------------------------------------------------- function TruncateSymrep( symrep : symbol_repNode.Locator; length : natural ) return string is TempName : String(1 .. length) := (others => ' '); begin if TOKEN.IsNull (symrep) then return TempName; else declare FullName : constant String :=SymRepToString (symrep); size : constant Integer := FullName'length; begin if size < length then TempName(1 .. Size) := FullName(1 .. Size); else TempName := FullName(1 .. length); end if; return TempName; end; end if; end TruncateSymrep; --------------------------------------------------------------------- ---- procedure DEF_ID_Analysis ( -- This procedure counts and analyzes -- all the identifiers in the program as -- either operands or operators. SetOfDEF_IDs :in DEF_ID_Set.Set; Nn :in out CT.NnInfoType; N2Star :in out natural ) is Place :DEF_ID_Set.SetIter; Member :DEF_ID.Locator; package DIS renames DEF_ID_Set; begin --| OVERVIEW --| Walk over the SetOfDEF_IDs. Each member in the set increments --| its class's Vocabulary by 1 and its class's Usage by the --| Countof the member. The Kind of each member determines --| which class it is in either an operator, an operand or --| neither. --| --| Calculate N2Star by counting the number of parameters to --| the program unit. Place := DIS.MakeSetIter (SetOfDEF_IDs); while DIS.More (Place) loop DIS.Next (Place, Member); case Kind (Member) is when ATTRIBUTE_IDKind | BUILT_IN_OPERATORKind | GENERAL_TYPE_IDKind | pkg_idKind | PRAGMA_IDKind | STM_IDKind | SUBP_IDKind | subtype_idKind | task_body_idKind => Nn(operator).Vocabulary := Nn(operator).Vocabulary + 1; Nn(operator).Usage := Nn(operator).Usage + DIS.GetCount (Place); if VerboseOn then Put (Standard_Output, "number of uses of "); Put (Standard_Output, SymRepToString (lx_symrep (Member))); Put (Standard_Output, " "); Put (Standard_Output, AnyKind 'image (Kind (Member))); Put (Standard_Output, " equals "); Put (Standard_Output, DIS.GetCount (Place)); Put (Standard_Output, " operators "); New_Line(Standard_Output); end if; when LITERAL_IDKind | OBJECT_IDKind| argument_idKind | exception_idKind | iteration_id | number_idKind => Nn(operand).Vocabulary := Nn(operand).Vocabulary + 1; Nn(operand).Usage := Nn(operand).Usage + DIS.GetCount (Place); if Kind (Member) in Param_idKind then N2Star := N2Star + 1; end if; if VerboseOn then Put (Standard_Output, "number of uses of "); Put (Standard_Output, SymRepToString (lx_symrep (Member))); Put (Standard_Output, " which is a "); Put (Standard_Output, AnyKind 'image (Kind (Member))); Put (Standard_Output, " equals "); Put (Standard_Output, DIS.GetCount (Place)); Put (Standard_Output, " operands "); New_Line (Standard_Output); end if; when others => null; end case; end loop; end DEF_ID_Analysis; -------------------------------------------------------------------------- procedure Literal_Analysis ( SetOfLiterals :in Literal_Set.Set; Nn :in out CT.NnInfoType ) is I :Literal_Set.SetIter; Member :Source_Text.Locator; package LS renames Literal_Set; begin --| OVERVIEW --| Walk over SetOfLiterals. Each member in the set increments --| the Vocabulary of the operands by one. The count of each --| member in the set increments the Usage of operands by the --| count. I := LS.MakeSetIter (SetOfLiterals); Nn(operand).Vocabulary := Nn(operand).Vocabulary + LS.Cardinality (SetOfLiterals); while LS.More (I) loop LS.Next (I, Member); Nn(operand).Usage := Nn(operand).Usage + LS.GetCount (I); if VerboseOn then Put (Standard_Output, "the literal "); Put (Standard_Output, VmmTextPkg.Value (Source_Text.Value (Member))); Put (Standard_Output, " appears "); Put (Standard_Output, LS.GetCount(I)); Put (Standard_Output, " times "); New_Line(Standard_Output); end if; end loop; end Literal_Analysis; -------------------------------------------------------------------------- function SeriesValue ( --| This function computes the ln (1 + x). X :in Float ) return Float is N :integer := 6; SumOfSeries :Float; Fraction :Float; LnOfTwo :Float; begin --| OVERVIEW --| --| The series for ln (1 + X) = --| --| x - x**2/2 + x**3/3 - x**4/4 + x**5/5 .... --| --| This is being factored inorder to save computations to be --| --| x ( 1 + x(-1/2 + x(1/3 + x(-1/4 ..... --| --| This is being computed from inside out. LnOfTwo := 6931.0/10000.0; SumOfSeries := 0.0; for i in reverse 1..N loop Fraction := 1.0/Float(i); if (i mod 2) = 0 then SumOfSeries := SumOfSeries - Fraction; else SumOfSeries := SumOfSeries + Fraction; end if; SumOfSeries := SumOfSeries * X; end loop; SumOfSeries := SumOfSeries / LnOfTwo; return SumOfSeries; end SeriesValue; -------------------------------------------------------------------------- function Log2 ( X :in Float ) return Float is U_X :Float; IntegerPart :Float; LogForFraction :Float; LowerBound :Float; X_For_Series :Float; InputOutOfBounds :exception; --| This computes the log2(X) by using the following method. --| --| First get the integer part of the log by testing when 2**n is --| greater than X. The integer part of log2(X) is then n - 1. --| --| Then we calculate the fraction part of log2(x) by using the --| expression --| --| ln(1 + x) = x - x**2/2 + x**3/3 - x**4/4 ..... --| --| Then by using the fact log2(x) = ln(X)/ln(2) we have log2(X). --| --| For example if x = 70 --| --| log2 (70) = log2 (64 * 70/64) = 6 + log2(70/64) --| --| log2( 70/64 )= log2( 1 + 6/64) = ln(1 + 6/64) / ln(2) --| --| log2 (1 + 64/70) is calculated by the function SeriesValue --| when passed (64/70). begin if X < 0.0 then raise InputOutOfBounds; else U_X := Float(Integer(X)); LowerBound := 1.0; IntegerPart := 0.0; while 2.0 * LowerBound <= U_X loop IntegerPart := IntegerPart + 1.0; LowerBound := LowerBound * 2.0; end loop; if LowerBound = U_X then return IntegerPart; else -- Following the example above at this point we compute -- log2 (70/64) = log2 (1 + 6/64) -- log2 (1 + 6/64) = SeriesValue (6/64). -- U_X - LowerBound is in the example 70 - 64. Therefore -- (U_X - LowerBound) / LowerBound is 6/64. X_For_Series := (U_X - LowerBound)/LowerBound; LogForFraction := SeriesValue(X_For_Series); return IntegerPart + LogForFraction; end if; end if; end Log2; -------------------------------------------------------------------------- function Exp ( --| Raises the natural log e to the power X. X :in Float ) return Float is NumberOfIterations :integer := 6; --| Number of Iterations used to calculate --| series. Series :Float; Factorial :Float; begin Series := 1.0; Factorial := 1.0; for i in 1..NumberOfIterations loop -- Caculate Factorial Factorial := Factorial * Float(i); Series := Series + ((X ** i) / Factorial); end loop; return Series; end Exp; -------------------------------------------------------------------------- function TwoThirdsPower ( --| Calculates X ** (2/3) by finding a --| a Y such that X ** 2 = Y ** 3 X :in Float ) return Float is Y :float := 1.0; SquareX :float; CubeY :float; CubeDelta :float; begin --| OVERVIEW --| Y = x ** (2/3) -> --| Y**3 = X**2 --| --| This function computes Y such that --| Y**3 <= X**2 is true. SquareX := X ** 2; CubeY := Y ** 3; CubeDelta := CubeY + ((3.0 * Y) * (Y + 1.0)) + 1.0; -- The following shows how to incremently compute (Y+1)**3 when -- Y **3 exists. -- -- ((Y + 1) ** 3) - (Y**3) = -- Y**3 + 3Y**2 + 3Y + 1 - Y**3 = -- 3Y**2 + 3Y + 1 = -- 3Y(Y + 1) + 1 while CubeY + CubeDelta < SquareX loop Y := Y + 1.0; CubeDelta := ((3.0 * Y) * (Y + 1.0)) + 1.0; end loop; return Y; end TwoThirdsPower; -------------------------------------------------------------------------- procedure CalcEstimatedProgramLength ( --| Computes the estimated program length --| given the number of unique operators --| and operands. N1 :in Float; --| number of unique operators N2 :in Float; --| number of unique operands Result :in out Float ) is begin Result := (N1 * log2(N1)) + (N2 * log2(N2)); end CalcEstimatedProgramLength; -------------------------------------------------------------------------- procedure CalcProgramVolume ( --| Computes the program volume --| given the vocabulary. ProgramLength :in Float; Vocabulary :in Float; Result :in out Float ) is begin Result := ProgramLength * log2(Vocabulary); end CalcProgramVolume; -------------------------------------------------------------------------- procedure CalcPotentialVolume( N2Star :in natural; --| minimum number of input output --| parameters. Result :in out Float ) is begin Result := (2.0 + Float(N2Star)) * log2(2.0 + Float(N2Star)); end CalcPotentialVolume; -------------------------------------------------------------------------- procedure CalcProgramLevel ( VStar :in Float; V :in Float; Result :in out Float ) is begin Result := VStar / V; exception when Numeric_Error => -- This catches the case when the denominator is 0. Result := 0.0; end CalcProgramLevel; -------------------------------------------------------------------------- procedure CalcProgramLevelApprox( --| minimum number of operators, --| number of unique operators, --| number of unique operands --| and total number of operands. N1 :in Float; N2Unique :in Float; N2Total :in Float; N1Star :in natural := 2; --| Minimum number of operators --| necessary Result :in out Float ) is begin Result := Float(N1Star)/N1 * N2Unique * N2Total; exception when Numeric_Error => -- This catches the case when the denominator is 0. Result := 0.0; end CalcProgramLevelApprox; -------------------------------------------------------------------------- procedure CalcIntelligenceContent ( L_Approx :in Float; V :in Float; Result :in out Float ) is begin Result := L_Approx * V; end CalcIntelligenceContent; -------------------------------------------------------------------------- procedure CalcProgrammingEffort ( V :in Float; L :in Float; Result :in out Float ) is begin Result := V / L; exception when Numeric_Error => -- This catches the case when the denominator is 0. Result := 0.0; end CalcProgrammingEffort; -------------------------------------------------------------------------- procedure CalcProgrammingTime ( E :in Float; S :in natural; --| Stroud number. Result :in out Float ) is begin Result := E/Float(S); end CalcProgrammingTime; -------------------------------------------------------------------------- procedure CalcLanguageLevel ( L :in Float; VStar :in Float; Result :in out Float ) is begin Result := L * VStar; end CalcLanguageLevel; -------------------------------------------------------------------------- procedure CalcNumberOfDeliveredErrors ( E :in Float; E0 :in natural; Result :in out Float ) is begin -- E**(2/3) / E0 Result := TwoThirdsPower(E) / Float(E0); end CalcNumberOfDeliveredErrors; -------------------------------------------------------------------------- procedure CalcApproxNumberOfDeliveredErrors ( V :in Float; E0 :in natural; Result :in out Float ) is begin Result := V / Float(E0); end CalcApproxNumberOfDeliveredErrors; -------------------------------------------------------------------------- procedure MetricCalculations ( Nn :in CT.NnInfoType; N2Star :in natural; Metrics :in out MetricsRecord ) is begin Metrics.UniqueOperators := Float(Nn(operator).Vocabulary); Metrics.UniqueOperands := Float(Nn(operand).Vocabulary); Metrics.OperandUsage := Float(Nn(operand).Usage); Metrics.OperatorUsage := Float(Nn(operator).Usage); Metrics.Vocabulary := Metrics.UniqueOperators + Metrics.UniqueOperands; Metrics.ProgramLength := Metrics.OperandUsage + Metrics.OperatorUsage; CalcEstimatedProgramLength(Metrics.UniqueOperators, Metrics.UniqueOperands, Metrics.EstimatedProgramLength); CalcProgramVolume(Metrics.ProgramLength, Metrics.Vocabulary, Metrics.ProgramVolume); CalcPotentialVolume(N2Star, Metrics.PotentialVolume); CalcProgramLevel(Metrics.PotentialVolume, Metrics.ProgramVolume, Metrics.ProgramLevel); CalcProgramLevelApprox(Metrics.UniqueOperators, Metrics.UniqueOperands, Metrics.OperandUsage, Result => Metrics.ProgramLevelApprox); CalcIntelligenceContent(Metrics.ProgramLevelApprox, Metrics.ProgramVolume, Metrics.IntelligenceContent); CalcProgrammingEffort(Metrics.ProgramVolume, Metrics.ProgramLevel, Metrics.ProgrammingEffort); CalcProgrammingTime(Metrics.ProgrammingEffort, StroudNumber, Metrics.ProgrammingTime); CalcLanguageLevel(Metrics.ProgramLevel, Metrics.PotentialVolume, Metrics.LanguageLevel); CalcNumberOfDeliveredErrors(Metrics.ProgrammingEffort, E0, Metrics.NumberOfDeliveredErrors); CalcApproxNumberOfDeliveredErrors( Metrics.ProgramVolume, E0, Metrics.ApproxNumberOfDeliveredErrors); end MetricCalculations; ------------------------------------------------------------------------- function Center ( --|This centers the string S in a buffer of blanks --|whose width is Width. S :in String; Width :in positive ) return String is Result :String(1..Width) := (others => ' '); Start :positive; Finish :positive; BufferToSmall :exception; begin Start := ((Result'length - S'length) / 2) + 1; Finish := Start + S'length - 1; if S'length > Width then raise BufferToSmall; else Result(Start..Finish) := S(S'range); return Result; end if; end Center; -------------------------------------------------------------------------- function RightJustify ( --| Right justify the string S in a buffer --| whose width is Width. S :in String; Width :in positive ) return String is Result :String(1..Width) := (others => ' '); Start :positive; Finish :positive; BufferToSmall :exception; begin if S'length > Width then raise BufferToSmall; else Start := (Result'length - S'length) + Result'first; Finish := Result'last; Result (Start..Finish) := S(S'range); return Result; end if; end RightJustify; -------------------------------------------------------------------------- function LeftJustify ( --| Left justify the string S in a buffer --| of blanks whose width is Width. S :in String; Width :in positive ) return String is Finish :positive; Result :String (1..Width) := (others => ' '); BufferToSmall :exception; begin if S'length > Width then raise BufferToSmall; else Finish := Result'first + S'length - 1; Result (Result'first..Finish) := S(S'range); return Result; end if; end LeftJustify; -------------------------------------------------------------------------- function StripTrailingBlanks ( --| Remove all trailing blanks from --| a string. Token :in String ) return String is begin for i in reverse Token'range loop if Token(i) /= ' ' then -- ith character is not a blank so return -- Token(Token'first..i) return Token(Token'first..i); end if; end loop; return ""; end StripTrailingBlanks; -------------------------------------------------------------------------- function IntTruncAndConvert ( --| Truncates and Converts an --| integer to a string of a given --| length. I :in integer; Width :in integer ) return String is Result :constant String := integer'image(I); begin -- Since image returns a leading blank the number of -- digits in I is length'Result - 1 if Result'length - 1 > Width then return Result(2..2 + Width - 1); else return Result(2..Result'length); end if; end IntTruncAndConvert; -------------------------------------------------------------------------- function Float_To_Int_Str ( X :in Float ) return String is begin return Integer'Image(Integer(X)); end Float_To_Int_Str; -------------------------------------------------------------------------- function FirstNonBlank ( S :in String ) return natural is Position :natural := S'first; begin while (S(Position) = ' ') and (Position <= S'last) loop Position := Position + 1; end loop; if Position in S'Range then return Position; else return 0; end if; end FirstNonBlank; -------------------------------------------------------------------------- function Float_To_Dec_Str ( X :in Float ) return String is TimesX :Float; begin --| OVERVIEW --| This function takes a Float and returns the image of the --| number in decimal notation. The number it returns has two --| places to the right of the decimal point or if the number is --| an integer it leaves two blanks. if X < 0.01 then return "<0.01"; elsif X > 1000000.0 then return ">1000000 "; end if; TimesX := X * 100.0; declare StrTimesX: constant String := Integer'Image(Integer(TimesX)); Result :String (1..StrTimesX'length + 1); FirstDigitPos :positive; LastDigitPos :positive; NumberOfDigits :positive; DecimalFillSpaces :constant String := " "; --| This ensures that there are three spaces to the right of --| ones places. This keeps all the numbers in line. begin if Integer(TimesX) = 0 then return "0" & DecimalFillSpaces ; else FirstDigitPos := FirstNonBlank (StrTimesX); NumberOfDigits := StrTimesX'last - FirstDigitPos + 1; if StrTimesX(StrTimesX'last - 1..StrTimesx'Last) = "00" then return StrTimesX(StrTimesX'First..StrTimesx'last - 2) & DecimalFillSpaces; end if; case NumberOfDigits is when 1 => Result(1..2) := ".0"; return Result(1..2) & StrTimesX (FirstDigitPos); when 2 => Result(1) := '.'; Result(2..3) := StrTimesX (FirstDigitPos..FirstDigitPos + NumberOfDigits -1); return Result (1..3); when others => LastDigitPos := FirstDigitPos + NumberOfDigits - 1; Result(1..NumberOfDigits - 2) := StrTimesX (FirstDigitPos..LastDigitPos - 2); Result(NumberOfDigits - 2 + 1) := '.'; Result(NumberOfDigits..NumberOfDigits + 1) := StrTimesX (LastDigitPos - 1..LastDigitPos); return Result (1..NumberOfDigits + 1); end case; end if; end; end Float_To_Dec_Str; -------------------------------------------------------------------------- procedure InsertInBuffer ( --| Insert the string "Insert" into Buffer --| preceeding a right Justified Field --| and a field which may have to be --| truncated with at least one blank. --| A left justified field does not have --| a blank preceeding it. Buffer :in out String; Insert :in String; StartPos :in positive; EndPos :in positive ) is begin Buffer (StartPos..EndPos) := Insert(Insert'Range); end InsertInBuffer; -------------------------------------------------------------------------- procedure PrintBlockId ( --| This procedure prints the identifying --| information for a block when producing --| the report. BlockId: in BlockIdType ) is begin --| OVERVIEW --| This prints --| 1. the kind of block --| 2. whether the block is a spec or body --| 3. the name of the block --| 4. the line number where the block appears in the source --| ALGORITHM --| Check if this is a declare block which is unnamed. If it is --| then process it differently. if BlockId.KindOfBlock = Definitions.declare_block and then BlockId.BlockName.all( BlockId.BlockName.all'first..BlockId.BlockName.all'last )= "" then Put ("UNNAMED DECLARE BLOCK"); else Put (StripTrailingBlanks (BlockStrings(BlockId.KindOfBlock))); Put (" "); Put (StripTrailingBlanks (BlockId.SpcBdyId)); Put (" OF "); Put ( BlockId.BlockName.all( BlockId.BlockName.all'first..BlockId.BlockName.all'last ) ); end if; Put (" AT LINE "); Put (BlockId.LineLocation); New_Line (Spacing => 2); end PrintBlockId; -------------------------------------------------------------------------- procedure PrintInfo ( BlockId: in BlockIdType; Metrics: in MetricsRecord ) is subtype BufferType is String (1..MaxLineLength); Output :BufferType; Blanks :BufferType := (others => ' '); LabelLength :constant positive := 20; subtype LabelType is String (1..LabelLength); subtype Metric_Index is natural range 1..NumberOfMetrics + 1; MetricLabels :constant array (Metric_Index) of LabelType:= ( "UNIQUE OPERATORS ", "UNIQUE OPERANDS ", "TOTAL OPERATORS ", "TOTAL OPERANDS ", "VOCABULARY ", " ", "PROGRAM LENGTH ", "ESTIMATED LENGTH ", "PROGRAM VOLUME ", "POTENTIAL VOLUME ", "PROGRAM LEVEL ", "ESTIMATED LEVEL ", "INTELLIGENCE CONTENT", "PROGRAMMING EFFORT ", "PROGRAMMING TIME ", "LANGUAGE LEVEL ", "DELIVERED ERRORS ", "ESTIMATED ERRORS " ); --| This array has one extra space for a metric. This is --| to make producing the report easier. subtype metric_range is integer range 1..NumberOfMetrics + 1; ProcessArray :array (metric_Range) of Float; --| This array has one extra space for a metric. This is --| to make producing the report easier. NumberOfMetricLines :constant positive := 9; FirstColValueField :positive; -- := LabelLength + 2; FirstCol :constant positive := 1; EndFirstCol :constant positive := 38; SecondCol :constant positive := 41; EndSecondCol :constant positive := 80; SecondColValueField :positive; -- := SecondCol+LabelLength+2- 1; i :integer; begin --| OVERVIEW --| This procedure produces the report for a block. The format of --| the report is the following: --| --|--------------------------------------------------------------- --| HALSTEAD COMPLEXITY FOR THE SPECIFICATION OF LIBRARY UNIT C36205D --| --| --| PROCEDURE SPECIFICATION OF C36205D AT LINE 12 --| --| UNIQUE OPERATORS 5 UNIQUE OPERANDS <0.01 --| TOTAL OPERATORS 6 TOTAL OPERANDS <0.01 --| VOCABULARY 5 --| PROGRAM LENGTH 6 ESTIMATED LENGTH 11.61 --| PROGRAM VOLUME 13.93 POTENTIAL VOLUME 2 --| PROGRAM LEVEL .14 ESTIMATED LEVEL <0.01 --| INTELLIGENCE CONTENT <0.01 PROGRAMMING EFFORT 97.06 --| PROGRAMMING TIME 19.41 LANGUAGE LEVEL .29 --| DELIVERED ERRORS <0.01 ESTIMATED ERRORS <0.01 --| --|--------------------------------------------------------------- --| The object FirstCol refers to the labels on the left hand side --| of the report. These are UNIQUE OPERATORS, TOTAL OPERATORS --| and so on. FirstColValueField is the refers to the leftmost --| position of the field where the numbers appear. --| The object SecondCol refers to the leftmost position of the --| labels for the second column. These are UNIQUE OPERANDS, --| TOTAL OPERANDS and so forth. SecondColValueField refers to --| the leftmost position of the value field. In this report --| are left justified or right justified in relation to a field. FirstColValueField := LabelLength + 2; SecondColValueField := SecondCol + LabelLength + 2 - 1; PrintBlockId (BlockId); ProcessArray(1) := Metrics.UniqueOperators; ProcessArray(2) := Metrics.UniqueOperands; ProcessArray(3) := Metrics.OperatorUsage; ProcessArray(4) := Metrics.OperandUsage; ProcessArray(5) := Metrics.Vocabulary; ProcessArray(6) := 0.0; ProcessArray(7) := Metrics.ProgramLength; ProcessArray(8) := Metrics.EstimatedProgramLength; ProcessArray(9) := Metrics.ProgramVolume; ProcessArray(10) := Metrics.PotentialVolume; ProcessArray(11) := Metrics.ProgramLevel; ProcessArray(12) := Metrics.ProgramLevelApprox; ProcessArray(13) := Metrics.IntelligenceContent; ProcessArray(14) := Metrics.ProgrammingEffort; ProcessArray(15) := Metrics.ProgrammingTime; ProcessArray(16) := Metrics.LanguageLevel; ProcessArray(17) := Metrics.NumberOfDeliveredErrors; ProcessArray(18) := Metrics.ApproxNumberOfDeliveredErrors; Output := Blanks; for j in 1..NumberOfMetricLines loop i := (j * 2) - 1; InsertInBuffer (Output, MetricLabels(i), FirstCol, LabelLength); InsertInBuffer (Output, RightJustify ( Float_To_Dec_Str (ProcessArray(i)), EndFirstCol - FirstColValueField + 1 ), FirstColValueField, EndFirstCol); -- Only do the following if i is not equal to 5 because -- if i equals 5 then we are processing the third line -- which doesn't have a second column so skip it. if i /= 5 then InsertInBuffer (Output, MetricLabels(i + 1), SecondCol, SecondCol + LabelLength - 1); InsertInBuffer (Output, RightJustify ( Float_To_Dec_Str (ProcessArray(i + 1) ), EndSecondCol - SecondColValueField + 1 ), SecondColValueField, EndSecondCol); end if; Put_Line (Output); Output := Blanks; end loop; -- Clear screen if printing to terminal. -- If writing to a file add two lines of spacing. if ToTerminal then New_Line (Spacing => NumberOfLinesToClearScreen); else New_Line (Spacing => 2); end if; end PrintInfo; -------------------------------------------------------------------------- function CopyQualifiedName ( FullyQualifiedName :in StringPtr ) return StringPtr is begin return new String ' (FullyQualifiedName.all); end CopyQualifiedName; -------------------------------------------------------------------------- procedure ExtendQualifiedName ( QualifiedName :in out StringPtr; Extension :in String ) is --| ALGORITHM --| Concatentate FullyQualifiedName with "." and the Extension --| then return the access to this. Free the space used by the --| QualifiedName. begin if Extension /= "" then if QualifiedName.all /= "" then QualifiedName := new String ' (QualifiedName.all & "." & Extension); else QualifiedName := new String ' (Extension); end if; end if; end ExtendQualifiedName; -------------------------------------------------------------------------- procedure TruncateQualifiedName ( FullyQualifiedName :in out StringPtr ) is --| ALGORITHM --| Remove the last qualification from FullyQualifiedName. --| When changing FullyQualifiedName free the space used by the --| old value. Trash :StringPtr := FullyQualifiedName; begin for i in reverse FullyQualifiedName.all'range loop if FullyQualifiedName(i) = '.' then FullyQualifiedName := new String ' (FullyQualifiedName(FullyQualifiedName.all'first..i-1)); Free (Trash); return; end if; end loop; Free (Trash); FullyQualifiedName := new String ' (""); end TruncateQualifiedName; -------------------------------------------------------------------------- -------------------------------------------------------------------------- -- VISIBLE SUBPROGRAMS -------------------------------------------------------------------------- -------------------------------------------------------------------------- procedure ReportHeader ( UnitName : String; Spec : boolean ) is begin if Spec then Put_Line ( Center ( "HALSTEAD COMPLEXITY FOR THE SPECIFICATION OF" & " LIBRARY UNIT " & UnitName, MaxLineLength ) ); else Put_Line ( Center ("HALSTEAD COMPLEXITY FOR THE BODY OF LIBRARY UNIT " & UnitName, MaxLineLength ) ); end if; New_Line (Spacing => 2); end ReportHeader; -------------------------------------------------------------------------- procedure InitializeData ( LibraryUnit :in String; IsUnitSpec :in boolean; VerboseFlag :in boolean; ToTerminalFlag :in boolean; OuterMostBlockFlag :in boolean ) is begin UnitName := new String ' (LibraryUnit(LibraryUnit'range)); FullyQualifiedName := new String ' (""); UnitSpec := IsUnitSpec; VerboseOn := VerboseFlag; ToTerminal := ToTerminalFlag; OuterMostBlockSeen := OuterMostBlockFlag; if ToTerminal then New_Page; end if; end InitializeData; -------------------------------------------------------------------------- procedure IncrementToken ( T :in TokenItem ) is begin CurrentBlock.TokenCount(T) := CurrentBlock.TokenCount(T) + 1; end IncrementToken; -------------------------------------------------------------------------- procedure FreeSpace ( CurrentBlock :in out BlockInfoType ) is begin Literal_Set.Destroy (CurrentBlock.SetOfLiterals); DEF_ID_Set.Destroy (CurrentBlock.SetOfDEF_IDs); end FreeSpace; -------------------------------------------------------------------------- function InitializeCurrentBlock return BlockInfoType is ClearedBlock :BlockInfoType; begin for t in TokenItem loop ClearedBlock.TokenCount(t) := 0; end loop; ClearedBlock.BlockId.BlockName := null; ClearedBlock.BlockId.KindOfBlock := declare_block; ClearedBlock.BlockId.SpcBdyId := AnonId; ClearedBlock.SetOfLiterals := Literal_Set.Create; ClearedBlock.SetOfDEF_IDs := DEF_ID_Set.Create; return ClearedBlock; end InitializeCurrentBlock; -------------------------------------------------------------------------- function LineNumber ( Position :in MLSP.Source_Position ) return MLSP.Source_Line is -- Get the line number of Position. begin return MLSP.Line (Position.first_location); end LineNumber; -------------------------------------------------------------------------- function IsSourceRange ( Position :in MLSP.Source_Position ) return boolean is --| ALGORITHM --| If Position.first_position /= Position.last_position then --| Position is a range and return true --| else --| Position is not a range and return false begin return not MLSP."=" (Position.first_location, Position.last_location); end; -------------------------------------------------------------------------- procedure SetBlockId ( ScopeName :in Symbol_repNode.Locator; KindOfBlock :in BlockKind; SpcBdyId :in SpcBdyIdType; Line_Number :in MLSP.Source_Line ) is begin -- If the ScopeName is "" then we have an unamed declare block. if SymRepToString (ScopeName) = "" then CurrentBlock.BlockId.BlockName := new String ' (""); else ExtendQualifiedName ( FullyQualifiedName, SymRepToString (ScopeName) ); CurrentBlock.BlockId.BlockName := CopyQualifiedName (FullyQualifiedName); end if; CurrentBlock.BlockId.KindOfBlock := KindOfBlock; CurrentBlock.BlockId.SpcBdyId := SpcBdyId; CurrentBlock.BlockId.LineLocation := Line_Number; end SetBlockId; -------------------------------------------------------------------------- procedure ProcessBlockInfo ( BlockInfo: in BlockInfoType ) is Nn :CT.NnInfoType; --| The counts in Nn represent the counts of operators and --| operands for Literal_Analysis and DEF_ID_Analysis. NnToken :CT.NnInfoType; --| This object keeps the counts of operators and operands --| which pertain to the reserved words and other syntactic --| constructs. Metrics :MetricsRecord; N2Star :natural := 0; begin if VerboseOn then Put_Line (Standard_Output, "DEF_ID_Analysis "); end if; DEF_ID_Analysis (BlockInfo.SetOfDEF_IDs, Nn, N2Star); if VerboseOn then Put_Line (Standard_Output, "Literal_Analysis"); end if; Literal_Analysis (BlockInfo.SetOfLiterals, Nn); CT.ZeroCount (NnToken); C.HalsteadCount (BlockInfo.TokenCount, VerboseOn, NnToken); if VerboseOn then New_Line (Standard_Output); Put_Line (Standard_Output,"------------------------------"); Put_Line (Standard_Output,"This separates countable units"); Put_Line (Standard_Output,"------------------------------"); New_Line (Standard_Output); end if; MetricCalculations ( CT.AddCounts (Nn, NnToken), N2Star, Metrics ); if ToTerminal then -- This block is needed because the boot seems to -- have trouble with -- ReportHeader (UnitName.all,UnitSpec); -- UnitName.all is causing the problem. declare LocalString : constant String := UnitName.all(UnitName.all'range); begin ReportHeader (LocalString, UnitSpec); end; end if; PrintInfo (BlockInfo.BlockId, Metrics); -- Truncate the current Scope Name. TruncateQualifiedName (FullyQualifiedName); end ProcessBlockInfo; -------------------------------------------------------------------------- end Halstead_Data_Base; :::::::::::::: hdb.spc :::::::::::::: -- $Source :/nosc/work/tools/halstead/RCS/utils.spc,v $ -- $Revision :1.11 $ -- $Date: 85/02/21 08:22:23 $ -- $Author: buddy $ with St_Diana; use St_Diana; with Definitions; use Definitions; with ML_Source_Position_Pkg; package Halstead_Data_Base is --| OVERVIEW --| This package holds the major global data structures and subprograms --| used to implement the Halstead Complexity Measures. --| EFFECTS --| This package has the data structures and subprograms used to compute --| the Halstead measures. ProcessBlock organizes the processing of the --| block's information. This entails counting the tokens as either --| operators or operands, determining the operand and operator Vocabulary --| and counting the total usage of operators and operands. --| It also involves counting the number of literals and performing --| analysis on all the identifiers in the block. Keeping track of the --| literals is performed by AddLiteral. This maintains a counted set --| of all the literals in the current block. The literal are counted --| as operands in the Halstead metrics. --| Analyzing the identifiers in the block is done in the subprogram --| DEF_ID_ANALYS.The identifiers are classified according to semantic --|information provided by DIANA. --| TUNING --| The procedure IncrementToken should be in lined using a pragma. -------------------------------------------------------------------------- -- VISIBLE OBJECTS -------------------------------------------------------------------------- package MLSP renames ML_Source_Position_Pkg; CurrentBlock :BlockInfoType; --| This contains the information about the block currently --| being processed. When a new block is encountered it is --| this information which gets pushed on the stack. BlockStack :BlockInfoStack.Stack; --| This structure stacks the information in the current block . --| Thus information is pushed onto the stack when we enter a --| new block and popped from the stack when we exit a block. --| This is used to reflect the visibility of operators and --| operands. OutermostBlockSeen :boolean; --| This is used to indicate that the outermost scope of the --| compilation unit has been seen. This is necessary because --| to include the context clauses as adding to the complexity of --| the outermost compilation unit. FullyQualifiedName :StringPtr; --| This is the fully qualified name of the current scope. This --| string is used in identifying the current scope in the output. UnitName :StringPtr; --| This is the name of library unit currently being processed. --| It is an access to a string since we don't know how long the --| will be. UnitSpec :boolean; --| This indicates whether the unit which is currently being --| processed is a specification or a body. VerboseOn :boolean; --| This boolean is used to control the printing of --| information pertaining to token counting. This shows --| tokens are counted, and what they are counted as. --| This information is always written to standard output. --| This paramater is set from the command line. The default --| for this is false. ToTerminal :boolean; --| This boolean is true if the user has not specified an output --| file which means the report is going to standard_output --| which is the terminal. -------------------------------------------------------------------------- -- VISIBLE SUBPROGRAMS -------------------------------------------------------------------------- -------------------------------------------------------------------------- procedure InitializeData ( --| This procedure passes the values --| of certain --| from the driver to this package which uses --| it in producing the report. It needs the --| the name of the library unit, whether the --| library unit is a specicification or a body, --| if the verbose flag is set, and whether the --| report is going to the terminal. LibraryUnit :in String; IsUnitSpec :in boolean; VerboseFlag :in boolean; ToTerminalFlag :in boolean; OuterMostBlockFlag :in boolean ); -------------------------------------------------------------------------- procedure ReportHeader ( --| This prints the header for a Library --| Unit. UnitName : String; Spec : boolean ); -------------------------------------------------------------------------- function InitializeCurrentBlock --| This function returns a record --| of type BlockInfoType which is --| initialized. return BlockInfoType; --| OVERVIEW --| This function is used before starting the scan of DIANA and --| then after a Push of CurrentBlock onto the stack. --| EFFECTS --| This function sets the TokenCount for each TokenItem to be 0. --| It also set the LiterSet to be empty and the ListOfDEF_ID to --| empty. -------------------------------------------------------------------------- procedure IncrementToken ( --| This procedure increments the count of --| of the given token for the current --| block. T :in TokenItem --| Token whose count is being incremented. ); --| OVERVIEW --| This procedure is called during the tree walking when the DIANA --| node which corresponds to the token T has been scanned. --| MODIFIES --| This increments CurrentBlock.TokenCount (T) which is the --| number of occurrences of the token T in the current block. --| TUNING --| This procedure should be pragma inlined. -------------------------------------------------------------------------- function LineNumber ( Position :in MLSP.Source_Position ) return MLSP.Source_Line; --| RAISES --| --| OVERVIEW --| Checks whether Position is a Source_Location or source_range. --| It then returns the line number of the starting position. --| EFFECTS --| --| REQUIRES --| --| MODIFIES --| --| ERRORS --| --| N/A --| --| TUNING --| --| NOTES --| -------------------------------------------------------------------------- function IsSourceRange ( Position :in MLSP.Source_Position ) return boolean; --| RAISES --| --| OVERVIEW --| This procedure checks if the Position is a source range. In --| the diana this indicate that the token had a beginning source --| location and an ending source location. Other tokens simply --| had a source point which was where the start of the token --| was in the source ( a line number and column position). --| The distinction between source_range and source_point is --| useful for distinguishing certain diana constructs. -------------------------------------------------------------------------- procedure SetBlockId ( --| This procedure initializes the --| identifying fields for the block. ScopeName :in Symbol_repNode.Locator; --| This is a Locator to the name of the block. KindOfBlock :in BlockKind; --| This is the kind of block. This can be a procedure, --| function, package, task or declare block. SpcBdyId :in SpcBdyIdType; --| This indicates whether the block is a spec or a body. Line_Number :in MLSP.Source_Line ); --| OVERVIEW --| This is used in the tree walk of DIANA when a node is --| scanned which indicates the name and type of the block. --| Typically a DEF_ID will be associated with a package, or --| subprogram, or task. The information passed to the --| routine is used in the reporting phase. --| MODIFIES --| This updates the BlockId component of CurrentBlock. --| EFFECTS --| The information in BlockId is used in the output routines to --| indicate the block. -------------------------------------------------------------------------- procedure FreeSpace ( --| Frees all the heap space which this --| record uses. CurrentBlock :in out BlockInfoType ); -------------------------------------------------------------------------- procedure ProcessBlockInfo ( --| Processes the information gathered --| for the current block. BlockInfo :in BlockInfoType --| This is the information for the block. ); --| OVERVIEW --| This procedure computes and output the Halstead Metrics for the --| current block. This procedure is invoked in the DIANA treewalk --| after a node which is a block has been completely processed. -------------------------------------------------------------------------- end Halstead_Data_Base; :::::::::::::: id_utils.bdy :::::::::::::: -- $Revision: 1.2 $ -- $Date: 86/02/06 18:05:16 $ -- $Author: buddy $ with ML_Source_Position_Pkg; package body Identifier_Utilities is package MLSP renames ML_Source_Position_Pkg; --| OVERVIEW --| This package has utilities which are used in processing --| DEF_ID's. function Is_Source_Position_Null ( Position :in MLSP.Source_Position ) return boolean; --| OVERVIEW --| This procedure returns true if the source position passed in --| is null. This means that column and line of the --| Position.first_location is 0. function Is_Id_Null ( Id :in DEF_ID.Locator ) return boolean is begin return Is_Source_Position_Null (lx_srcpos (id)); end; -------------------------------------------------------------------------- function Is_Source_Position_Null ( Position :in MLSP.Source_Position ) return boolean is begin return MLSP."=" (Position.first_location,0); end; end Identifier_Utilities; -------------------------------------------------------------------------- :::::::::::::: id_utils.spc :::::::::::::: with ST_DIANA; use ST_DIANA; package Identifier_Utilities is --| OVERVIEW --| This package has utilities which are used in processing --| DEF_ID's. function Is_Id_Null ( Id :in DEF_ID.Locator ) return boolean ; end Identifier_Utilities; :::::::::::::: ihagg_nam.dat :::::::::::::: -- Begin: IHagg_named dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package agg_named_IH is type RecType is record ih_inagg_named : boolean; end record; R : RecType; end agg_named_IH; -- End: IHagg_named dat ----------------------------------------------------- :::::::::::::: ihblock_s.dat :::::::::::::: -- Begin: IHblock_stm dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package block_stm_IH is type RecType is record ih_inblock : boolean; end record; R : RecType; end block_stm_IH; -- End: IHblock_stm dat ----------------------------------------------------- :::::::::::::: ihcase_al.dat :::::::::::::: -- Begin: IHcase_alternative dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package case_alternative_IH is type RecType is record ih_incase_alternative : boolean; end record; R : RecType; end case_alternative_IH; -- End: IHcase_alternative dat ----------------------------------------------------- :::::::::::::: ihgeneric.dat :::::::::::::: -- Begin: IHgeneric_header dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package generic_header_IH is type RecType is record ih_ingeneric_param : boolean; end record; R : RecType; end generic_header_IH; -- End: IHgeneric_header dat ----------------------------------------------------- :::::::::::::: ihhandler.dat :::::::::::::: -- Begin: IHhandler_alternative dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package handler_alternative_IH is type RecType is record ih_inhandler_alternative : boolean; end record; R : RecType; end handler_alternative_IH; -- End: IHhandler_alternative dat ----------------------------------------------------- :::::::::::::: ihinner_r.dat :::::::::::::: -- Begin: IHinner_record dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package inner_record_IH is type RecType is record ih_in_variant : boolean; end record; R : RecType; end inner_record_IH; -- End: IHinner_record dat ----------------------------------------------------- :::::::::::::: ihseries_.dat :::::::::::::: -- Begin: IHSERIES_UNIT dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package SERIES_UNIT_IH is type RecType is record ih_inlist : boolean; end record; R : RecType; end SERIES_UNIT_IH; -- End: IHSERIES_UNIT dat ----------------------------------------------------- :::::::::::::: ihsubtype.dat :::::::::::::: -- Begin: IHsubtype_decl dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package subtype_decl_IH is type RecType is record ih_in_subtype_decl : boolean; end record; R : RecType; end subtype_decl_IH; -- End: IHsubtype_decl dat ----------------------------------------------------- :::::::::::::: ihtask_de.dat :::::::::::::: -- Begin: IHtask_decl dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with Unchecked_Deallocation; package task_decl_IH is type RecType is record ih_intask_decl : boolean; end record; R : RecType; end task_decl_IH; -- End: IHtask_decl dat ----------------------------------------------------- :::::::::::::: ihtype_de.dat :::::::::::::: -- Begin: IHtype_decl dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with ST_Diana; use ST_Diana; with Unchecked_Deallocation; package type_decl_IH is type RecType is record ih_typespec : Anykind; ih_basetype : DEF_ID.Locator; end record; R : RecType; end type_decl_IH; -- End: IHtype_decl dat ----------------------------------------------------- :::::::::::::: ihvariabl.dat :::::::::::::: -- Begin: IHvariable_decl dat --------------------------------------------------- with ST_DIANA; use ST_DIANA; with ST_Diana; use ST_Diana; with Unchecked_Deallocation; package variable_decl_IH is type RecType is record ih_vartype : MARK.Locator; ih_init : boolean; end record; R : RecType; end variable_decl_IH; -- End: IHvariable_decl dat ----------------------------------------------------- :::::::::::::: obj.bdy :::::::::::::: -- Begin: SCOBJECT_TYPE bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with TYPE_SPEC_Pkg; use TYPE_SPEC_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with CONSTRAINT_Pkg; use CONSTRAINT_Pkg; with subtype_decl_IH; package body OBJECT_TYPE_Pkg is procedure Scan_OBJECT_TYPE(Root : OBJECT_TYPE.Locator) is begin case Kind(Root) is when object_type_anon_arrayKind => Scan_object_type_anon_array(Root); when object_type_anon_taskKind => Scan_object_type_anon_task(Root); when object_type_constrainedKind => Scan_object_type_constrained(Root); when object_type_indexKind => Scan_object_type_index(Root); when object_type_rangeKind => Scan_object_type_range(Root); when others => null; end case; end Scan_OBJECT_TYPE; procedure Scan_object_type_anon_array(Root : object_type_anon_arrayNode.Locator) is begin Scan_constrained_array_type(as_array_type_spec(Root)); end Scan_object_type_anon_array; procedure Scan_object_type_anon_task(Root : object_type_anon_taskNode.Locator) is begin Scan_task_spec(as_task_spec(Root)); end Scan_object_type_anon_task; procedure Scan_object_type_constrained(Root : object_type_constrainedNode.Locator) is begin if not MARK.IsNull(as_constrained_name(Root)) then Scan_MARK(as_constrained_name(Root)); end if; if not CONSTRAINT.IsNull(as_constraint(Root)) then if (subtype_decl_IH.R.ih_in_subtype_decl) and then (Kind (as_constraint (root)) not in dscrmt_constraintKind) then IncrementToken (rangez); end if; Scan_CONSTRAINT(as_constraint(Root)); end if; end Scan_object_type_constrained; procedure Scan_object_type_index(Root : object_type_indexNode.Locator) is begin if not MARK.IsNull(as_index_name(Root)) then Scan_MARK(as_index_name(Root)); IncrementToken (rangez); end if; end Scan_object_type_index; procedure Scan_object_type_range(Root : object_type_rangeNode.Locator) is begin if not RANGE_CONSTRAINT_CLASS.IsNull(as_range_constraint(Root)) then Scan_RANGE_CONSTRAINT_CLASS(as_range_constraint(Root)); end if; end Scan_object_type_range; end OBJECT_TYPE_Pkg; -- End: SCOBJECT_TYPE bdy ----------------------------------------------------- :::::::::::::: obj.spc :::::::::::::: -- Begin: SCOBJECT_TYPE spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package OBJECT_TYPE_Pkg is procedure Scan_OBJECT_TYPE(Root : OBJECT_TYPE.Locator); procedure Scan_object_type_anon_array(Root : object_type_anon_arrayNode.Locator); procedure Scan_object_type_anon_task(Root : object_type_anon_taskNode.Locator); procedure Scan_object_type_constrained(Root : object_type_constrainedNode.Locator); procedure Scan_object_type_index(Root : object_type_indexNode.Locator); procedure Scan_object_type_range(Root : object_type_rangeNode.Locator); end OBJECT_TYPE_Pkg; -- End: SCOBJECT_TYPE spc ----------------------------------------------------- :::::::::::::: scagg_com.bdy :::::::::::::: -- Begin: SCAGG_COMPONENT bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with agg_named_IH; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with CHOICE_Pkg; use CHOICE_Pkg; package body AGG_COMPONENT_Pkg is procedure Scan_AGG_COMPONENT(Root : AGG_COMPONENT.Locator) is begin case Kind(Root) is when agg_canonicalKind => Scan_agg_canonical(Root); when agg_expKind => Scan_agg_exp(Root); when agg_namedKind => Scan_agg_named(Root); when others => null; end case; end Scan_AGG_COMPONENT; procedure Scan_agg_canonical(Root : agg_canonicalNode.Locator) is Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_agg_canonical; procedure Scan_agg_exp(Root : agg_expNode.Locator) is Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_exp(Root)) then Scan_NAME_EXP(as_exp(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_agg_exp; procedure Scan_agg_named(Root : agg_namedNode.Locator) is as_choice_s_List : SeqOfCHOICE.Generator; as_choice_s_Item : CHOICE.Locator; use SeqOfCHOICE; Old_agg_named_IHR : agg_named_IH.RecType := agg_named_IH.R; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin agg_named_IH.R.ih_inagg_named := false ; SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfCHOICE.IsNull(as_choice_s(Root)) then agg_named_IH.R.ih_inagg_named := true; StartForward(as_choice_s(Root), as_choice_s_List); while not Finished(as_choice_s_List) loop as_choice_s_Item := Cell(as_choice_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (barz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_CHOICE(as_choice_s_Item); Forward(as_choice_s_List); end loop; EndIterate(as_choice_s_List); IncrementToken (arrowz); agg_named_IH.R.ih_inagg_named := false; end if; if not NAME_EXP.IsNull(as_exp(Root)) then Scan_NAME_EXP(as_exp(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; agg_named_IH.R := Old_agg_named_IHR; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_agg_named; end AGG_COMPONENT_Pkg; -- End: SCAGG_COMPONENT bdy ----------------------------------------------------- :::::::::::::: scagg_com.spc :::::::::::::: -- Begin: SCAGG_COMPONENT spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package AGG_COMPONENT_Pkg is procedure Scan_AGG_COMPONENT(Root : AGG_COMPONENT.Locator); procedure Scan_agg_canonical(Root : agg_canonicalNode.Locator); procedure Scan_agg_exp(Root : agg_expNode.Locator); procedure Scan_agg_named(Root : agg_namedNode.Locator); end AGG_COMPONENT_Pkg; -- End: SCAGG_COMPONENT spc ----------------------------------------------------- :::::::::::::: scalterna.bdy :::::::::::::: -- Begin: SCALTERNATIVE bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with case_alternative_IH; with handler_alternative_IH; with CHOICE_Pkg; use CHOICE_Pkg; with STM_Pkg; use STM_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with ITEM_Pkg; use ITEM_Pkg; package body ALTERNATIVE_Pkg is procedure Scan_ALTERNATIVE(Root : ALTERNATIVE.Locator) is begin case Kind(Root) is when case_alternativeKind => Scan_case_alternative(Root); when cond_alternativeKind => Scan_cond_alternative(Root); when handler_alternativeKind => Scan_handler_alternative(Root); when pragma_alternativeKind => Scan_pragma_alternative(Root); when select_alternativeKind => Scan_select_alternative(Root); when others => null; end case; end Scan_ALTERNATIVE; procedure Scan_case_alternative(Root : case_alternativeNode.Locator) is as_case_choice_s_List : SeqOfCHOICE.Generator; as_case_choice_s_Item : CHOICE.Locator; use SeqOfCHOICE; as_stm_s_List : SeqOfSTM.Generator; as_stm_s_Item : STM.Locator; use SeqOfSTM; Old_case_alternative_IHR : case_alternative_IH.RecType := case_alternative_IH.R; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin case_alternative_IH.R.ih_incase_alternative := false ; SERIES_UNIT_IH.R.ih_inlist := false ; case_alternative_IH.R.ih_incase_alternative := true; IncrementToken (when_case_stmz); IncrementToken (arrowz); if not SeqOfCHOICE.IsNull(as_case_choice_s(Root)) then StartForward(as_case_choice_s(Root), as_case_choice_s_List); while not Finished(as_case_choice_s_List) loop as_case_choice_s_Item := Cell(as_case_choice_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (barz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_CHOICE(as_case_choice_s_Item); Forward(as_case_choice_s_List); end loop; EndIterate(as_case_choice_s_List); end if; if not SeqOfSTM.IsNull(as_stm_s(Root)) then StartForward(as_stm_s(Root), as_stm_s_List); while not Finished(as_stm_s_List) loop as_stm_s_Item := Cell(as_stm_s_List); Scan_STM(as_stm_s_Item); Forward(as_stm_s_List); end loop; EndIterate(as_stm_s_List); end if; case_alternative_IH.R.ih_incase_alternative := false; case_alternative_IH.R := Old_case_alternative_IHR; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_case_alternative; procedure Scan_cond_alternative(Root : cond_alternativeNode.Locator) is as_stm_s_List : SeqOfSTM.Generator; as_stm_s_Item : STM.Locator; use SeqOfSTM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_cond_exp_void(Root)) then if IsSourceRange (lx_srcpos(root)) then IncrementToken (elsifz); end if; end if; if NAME_EXP.IsNull(as_cond_exp_void(Root)) then IncrementToken (else_ifz); end if; if not NAME_EXP.IsNull(as_cond_exp_void(Root)) then Scan_NAME_EXP(as_cond_exp_void(Root)); end if; if not SeqOfSTM.IsNull(as_stm_s(Root)) then if not NAME_EXP.IsNull(as_cond_exp_void(Root)) then IncrementToken (thenz); end if; StartForward(as_stm_s(Root), as_stm_s_List); while not Finished(as_stm_s_List) loop as_stm_s_Item := Cell(as_stm_s_List); Scan_STM(as_stm_s_Item); Forward(as_stm_s_List); end loop; EndIterate(as_stm_s_List); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_cond_alternative; procedure Scan_handler_alternative(Root : handler_alternativeNode.Locator) is as_handler_choice_s_List : SeqOfCHOICE.Generator; as_handler_choice_s_Item : CHOICE.Locator; use SeqOfCHOICE; as_stm_s_List : SeqOfSTM.Generator; as_stm_s_Item : STM.Locator; use SeqOfSTM; Old_handler_alternative_IHR : handler_alternative_IH.RecType := handler_alternative_IH.R; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin handler_alternative_IH.R.ih_inhandler_alternative := false ; SERIES_UNIT_IH.R.ih_inlist := false ; handler_alternative_IH.R.ih_inhandler_alternative := true; IncrementToken (when_exceptionz); IncrementToken (arrowz); if not SeqOfCHOICE.IsNull(as_handler_choice_s(Root)) then StartForward(as_handler_choice_s(Root), as_handler_choice_s_List); while not Finished(as_handler_choice_s_List) loop as_handler_choice_s_Item := Cell(as_handler_choice_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (barz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_CHOICE(as_handler_choice_s_Item); Forward(as_handler_choice_s_List); end loop; EndIterate(as_handler_choice_s_List); end if; if not SeqOfSTM.IsNull(as_stm_s(Root)) then StartForward(as_stm_s(Root), as_stm_s_List); while not Finished(as_stm_s_List) loop as_stm_s_Item := Cell(as_stm_s_List); Scan_STM(as_stm_s_Item); Forward(as_stm_s_List); end loop; EndIterate(as_stm_s_List); end if; handler_alternative_IH.R.ih_inhandler_alternative := false; SERIES_UNIT_IH.R.ih_inlist := false; handler_alternative_IH.R := Old_handler_alternative_IHR; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_handler_alternative; procedure Scan_pragma_alternative(Root : pragma_alternativeNode.Locator) is Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not pragma_declNode.IsNull(as_pragma_alternative(Root)) then Scan_pragma_decl(as_pragma_alternative(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_pragma_alternative; procedure Scan_select_alternative(Root : select_alternativeNode.Locator) is as_stm_s_List : SeqOfSTM.Generator; as_stm_s_Item : STM.Locator; use SeqOfSTM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_select_exp_void(Root)) then IncrementToken (when_selectz); Scan_NAME_EXP(as_select_exp_void(Root)); IncrementToken (arrowz); end if; if not SeqOfSTM.IsNull(as_stm_s(Root)) then StartForward(as_stm_s(Root), as_stm_s_List); while not Finished(as_stm_s_List) loop as_stm_s_Item := Cell(as_stm_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (or_selectz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_STM(as_stm_s_Item); Forward(as_stm_s_List); end loop; EndIterate(as_stm_s_List); end if; SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_select_alternative; end ALTERNATIVE_Pkg; -- End: SCALTERNATIVE bdy ----------------------------------------------------- :::::::::::::: scalterna.spc :::::::::::::: -- Begin: SCALTERNATIVE spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package ALTERNATIVE_Pkg is procedure Scan_ALTERNATIVE(Root : ALTERNATIVE.Locator); procedure Scan_case_alternative(Root : case_alternativeNode.Locator); procedure Scan_cond_alternative(Root : cond_alternativeNode.Locator); procedure Scan_handler_alternative(Root : handler_alternativeNode.Locator); procedure Scan_pragma_alternative(Root : pragma_alternativeNode.Locator); procedure Scan_select_alternative(Root : select_alternativeNode.Locator); end ALTERNATIVE_Pkg; -- End: SCALTERNATIVE spc ----------------------------------------------------- :::::::::::::: scblock_s.bdy :::::::::::::: -- Begin: SCBLOCK_STUB bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with ITEM_Pkg; use ITEM_Pkg; with STM_Pkg; use STM_Pkg; with ALTERNATIVE_Pkg; use ALTERNATIVE_Pkg; with BLOCK_STM_IH; with Source_Position_Utilities; package body BLOCK_STUB_Pkg is procedure Scan_BLOCK_STUB(Root : BLOCK_STUB.Locator) is begin case Kind(Root) is when body_blockKind => Scan_body_block(Root); when body_stubKind => Scan_body_stub(Root); when others => null; end case; end Scan_BLOCK_STUB; procedure Scan_body_block(Root : body_blockNode.Locator) is as_item_s_List : SeqOfITEM.Generator; as_item_s_Item : ITEM.Locator; use SeqOfITEM; as_stm_s_List : SeqOfSTM.Generator; as_stm_s_Item : STM.Locator; use SeqOfSTM; as_handler_s_List : SeqOfhandler_alternativeNode.Generator; as_handler_s_Item : handler_alternativeNode.Locator; use SeqOfhandler_alternativeNode; begin if not SeqOfITEM.IsNull(as_item_s(Root)) then if block_stm_IH.R.ih_inblock then IncrementToken (declarez); block_stm_IH.R.ih_inblock := false; end if; StartForward(as_item_s(Root), as_item_s_List); while not Finished(as_item_s_List) loop as_item_s_Item := Cell(as_item_s_List); Scan_ITEM(as_item_s_Item); Forward(as_item_s_List); end loop; EndIterate(as_item_s_List); end if; if not SeqOfSTM.IsNull(as_stm_s(Root)) then IncrementToken (beginz); StartForward(as_stm_s(Root), as_stm_s_List); while not Finished(as_stm_s_List) loop as_stm_s_Item := Cell(as_stm_s_List); Scan_STM(as_stm_s_Item); Forward(as_stm_s_List); end loop; EndIterate(as_stm_s_List); end if; if not SeqOfhandler_alternativeNode.IsNull(as_handler_s(Root)) then IncrementToken (exceptionz); StartForward(as_handler_s(Root), as_handler_s_List); while not Finished(as_handler_s_List) loop as_handler_s_Item := Cell(as_handler_s_List); Scan_handler_alternative(as_handler_s_Item); Forward(as_handler_s_List); end loop; EndIterate(as_handler_s_List); end if; if not Source_Position_Utilities.Is_Srcpos_Null (lx_srcpos (root)) then IncrementToken (end_beginz); end if; end Scan_body_block; procedure Scan_body_stub(Root : body_stubNode.Locator) is begin --- should be is_separatez not is_packagez IncrementToken (is_separatez); IncrementToken (separatez); end Scan_body_stub; end BLOCK_STUB_Pkg; -- End: SCBLOCK_STUB bdy ----------------------------------------------------- :::::::::::::: scblock_s.spc :::::::::::::: -- Begin: SCBLOCK_STUB spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package BLOCK_STUB_Pkg is procedure Scan_BLOCK_STUB(Root : BLOCK_STUB.Locator); procedure Scan_body_block(Root : body_blockNode.Locator); procedure Scan_body_stub(Root : body_stubNode.Locator); end BLOCK_STUB_Pkg; -- End: SCBLOCK_STUB spc ----------------------------------------------------- :::::::::::::: scchoice.bdy :::::::::::::: -- Begin: SCCHOICE bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with agg_named_IH; with case_alternative_IH; with handler_alternative_IH; with inner_record_IH; package body CHOICE_Pkg is procedure Scan_CHOICE(Root : CHOICE.Locator) is begin case Kind(Root) is when ch_discrete_rangeKind => Scan_ch_discrete_range(Root); when ch_expKind => Scan_ch_exp(Root); when ch_othersKind => Scan_ch_others(Root); when others => null; end case; end Scan_CHOICE; procedure Scan_ch_discrete_range(Root : ch_discrete_rangeNode.Locator) is begin if not OBJECT_TYPE.IsNull(as_discrete_range(Root)) then Scan_OBJECT_TYPE(as_discrete_range(Root)); end if; end Scan_ch_discrete_range; procedure Scan_ch_exp(Root : ch_expNode.Locator) is begin if not NAME_EXP.IsNull(as_exp(Root)) then Scan_NAME_EXP(as_exp(Root)); end if; end Scan_ch_exp; procedure Scan_ch_others(Root : ch_othersNode.Locator) is begin if agg_named_IH.R.ih_inagg_named then IncrementToken (others_aggregatez); end if; if case_alternative_IH.R.ih_incase_alternative then IncrementToken (others_casez); end if; if handler_alternative_IH.R.ih_inhandler_alternative then IncrementToken (others_exceptionz); end if; if inner_record_IH.R.ih_in_variant then IncrementToken (others_variantz); end if; end Scan_ch_others; end CHOICE_Pkg; -- End: SCCHOICE bdy ----------------------------------------------------- :::::::::::::: scchoice.spc :::::::::::::: -- Begin: SCCHOICE spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package CHOICE_Pkg is procedure Scan_CHOICE(Root : CHOICE.Locator); procedure Scan_ch_discrete_range(Root : ch_discrete_rangeNode.Locator); procedure Scan_ch_exp(Root : ch_expNode.Locator); procedure Scan_ch_others(Root : ch_othersNode.Locator); end CHOICE_Pkg; -- End: SCCHOICE spc ----------------------------------------------------- :::::::::::::: sccomp_un.bdy :::::::::::::: -- Begin: SCCOMP_UNIT_CLASS bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with ITEM_Pkg; use ITEM_Pkg; package body COMP_UNIT_CLASS_Pkg is procedure Scan_COMP_UNIT_CLASS(Root : COMP_UNIT_CLASS.Locator) is begin case Kind(Root) is when comp_unitKind => Scan_comp_unit(Root); when others => null; end case; end Scan_COMP_UNIT_CLASS; procedure Scan_comp_unit(Root : comp_unitNode.Locator) is as_context_List : SeqOfITEM.Generator; as_context_Item : ITEM.Locator; use SeqOfITEM; as_pragma_s_List : SeqOfpragma_declNode.Generator; as_pragma_s_Item : pragma_declNode.Locator; use SeqOfpragma_declNode; begin CurrentBlock := InitializeCurrentBlock; BlockStack := BlockInfoStack.Create; -- This adds a dummy frame on the stack so that it is not necessary -- to check when popping the stack at the end of the program -- if the stack has at least one record. BlockInfoStack.Push(BlockStack, CurrentBlock); if Kind (as_unit_body (root)) in subp_declKind then if Kind (as_subp_designator (as_unit_body (root))) in proc_idKind then SetBlockId (lx_symrep (as_subp_designator (as_unit_body (root))), procedure_block, SpcId, LineNumber (lx_srcpos (as_unit_body (root))) ); else SetBlockId (lx_symrep (as_subp_designator (as_unit_body (root))), function_block, SpcId, LineNumber (lx_srcpos (as_unit_body (root))) ); end if; end if; if not SeqOfITEM.IsNull(as_context(Root)) then StartForward(as_context(Root), as_context_List); while not Finished(as_context_List) loop as_context_Item := Cell(as_context_List); Scan_ITEM(as_context_Item); Forward(as_context_List); end loop; EndIterate(as_context_List); end if; if not SeqOfpragma_declNode.IsNull(as_pragma_s(Root)) then StartForward(as_pragma_s(Root), as_pragma_s_List); while not Finished(as_pragma_s_List) loop as_pragma_s_Item := Cell(as_pragma_s_List); Scan_pragma_decl(as_pragma_s_Item); Forward(as_pragma_s_List); end loop; EndIterate(as_pragma_s_List); end if; if not ITEM.IsNull(as_unit_body(Root)) then Scan_ITEM(as_unit_body(Root)); end if; if Kind (as_unit_body (root)) in subp_declKind then ProcessBlockInfo (CurrentBlock); end if; end Scan_comp_unit; end COMP_UNIT_CLASS_Pkg; -- End: SCCOMP_UNIT_CLASS bdy ----------------------------------------------------- :::::::::::::: sccomp_un.spc :::::::::::::: -- Begin: SCCOMP_UNIT_CLASS spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package COMP_UNIT_CLASS_Pkg is procedure Scan_COMP_UNIT_CLASS(Root : COMP_UNIT_CLASS.Locator); procedure Scan_comp_unit(Root : comp_unitNode.Locator); end COMP_UNIT_CLASS_Pkg; -- End: SCCOMP_UNIT_CLASS spc ----------------------------------------------------- :::::::::::::: scconstra.bdy :::::::::::::: -- Begin: SCCONSTRAINT bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with GENERAL_ASSOC_Pkg; use GENERAL_ASSOC_Pkg; with AGG_COMPONENT_Pkg; use AGG_COMPONENT_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with subtype_decl_IH; package body CONSTRAINT_Pkg is procedure Scan_CONSTRAINT(Root : CONSTRAINT.Locator) is begin case Kind(Root) is when RANGE_CONSTRAINT_CLASSKind => Scan_RANGE_CONSTRAINT_CLASS(Root); when REAL_CONSTRAINTKind => Scan_REAL_CONSTRAINT(Root); when apply_constraintKind => Scan_apply_constraint(Root); when dscrmt_constraintKind => Scan_dscrmt_constraint(Root); when index_constraintKind => Scan_index_constraint(Root); when others => null; end case; end Scan_CONSTRAINT; procedure Scan_RANGE_CONSTRAINT_CLASS(Root : RANGE_CONSTRAINT_CLASS.Locator) is begin case Kind(Root) is when range_attribute_constraintKind => Scan_range_attribute_constraint(Root); when range_constraintKind => Scan_range_constraint(Root); when others => null; end case; end Scan_RANGE_CONSTRAINT_CLASS; procedure Scan_range_attribute_constraint(Root : range_attribute_constraintNode.Locator) is begin if not NAME_EXP.IsNull(as_range_exp(Root)) then Scan_NAME_EXP(as_range_exp(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; end Scan_range_attribute_constraint; procedure Scan_range_constraint(Root : range_constraintNode.Locator) is begin if IsSourceRange (lx_srcpos (root)) and then not subtype_decl_IH.R.ih_in_subtype_decl then -- The check for subtype is necessary because in object_type -- we count range if it is a subtype. This check prevents -- us from counting range twice. IncrementToken (rangez); end if; if not NAME_EXP.IsNull(as_range_exp1(Root)) then Scan_NAME_EXP(as_range_exp1(Root)); IncrementToken (dot_dot_rangez); end if; if not NAME_EXP.IsNull(as_range_exp2(Root)) then Scan_NAME_EXP(as_range_exp2(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; end Scan_range_constraint; procedure Scan_REAL_CONSTRAINT(Root : REAL_CONSTRAINT.Locator) is begin case Kind(Root) is when fixed_constraintKind => Scan_fixed_constraint(Root); when float_constraintKind => Scan_float_constraint(Root); when others => null; end case; end Scan_REAL_CONSTRAINT; procedure Scan_fixed_constraint(Root : fixed_constraintNode.Locator) is begin if not NAME_EXP.IsNull(as_delta(Root)) then Scan_NAME_EXP(as_delta(Root)); end if; if not range_constraintNode.IsNull(as_range_constraint(Root)) then Scan_range_constraint(as_range_constraint(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; end Scan_fixed_constraint; procedure Scan_float_constraint(Root : float_constraintNode.Locator) is begin if not NAME_EXP.IsNull(as_digits(Root)) then Scan_NAME_EXP(as_digits(Root)); end if; if not range_constraintNode.IsNull(as_range_constraint(Root)) then Scan_range_constraint(as_range_constraint(Root)); end if; SERIES_UNIT_IH.R.ih_inlist := false; end Scan_float_constraint; procedure Scan_apply_constraint(Root : apply_constraintNode.Locator) is as_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; begin if not SeqOfGENERAL_ASSOC.IsNull(as_assoc_s(Root)) then StartForward(as_assoc_s(Root), as_assoc_s_List); while not Finished(as_assoc_s_List) loop as_assoc_s_Item := Cell(as_assoc_s_List); Scan_GENERAL_ASSOC(as_assoc_s_Item); Forward(as_assoc_s_List); end loop; EndIterate(as_assoc_s_List); end if; SERIES_UNIT_IH.R.ih_inlist := false; end Scan_apply_constraint; procedure Scan_dscrmt_constraint(Root : dscrmt_constraintNode.Locator) is as_dscrmt_assoc_s_List : SeqOfAGG_COMPONENT.Generator; as_dscrmt_assoc_s_Item : AGG_COMPONENT.Locator; use SeqOfAGG_COMPONENT; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); if not SeqOfAGG_COMPONENT.IsNull(as_dscrmt_assoc_s(Root)) then StartForward(as_dscrmt_assoc_s(Root), as_dscrmt_assoc_s_List); while not Finished(as_dscrmt_assoc_s_List) loop as_dscrmt_assoc_s_Item := Cell(as_dscrmt_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_AGG_COMPONENT(as_dscrmt_assoc_s_Item); Forward(as_dscrmt_assoc_s_List); end loop; EndIterate(as_dscrmt_assoc_s_List); end if; IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_dscrmt_constraint; procedure Scan_index_constraint(Root : index_constraintNode.Locator) is as_discrete_range_s_List : SeqOfOBJECT_TYPE.Generator; as_discrete_range_s_Item : OBJECT_TYPE.Locator; use SeqOfOBJECT_TYPE; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); if not SeqOfOBJECT_TYPE.IsNull(as_discrete_range_s(Root)) then StartForward(as_discrete_range_s(Root), as_discrete_range_s_List); while not Finished(as_discrete_range_s_List) loop as_discrete_range_s_Item := Cell(as_discrete_range_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_OBJECT_TYPE(as_discrete_range_s_Item); Forward(as_discrete_range_s_List); end loop; EndIterate(as_discrete_range_s_List); end if; IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_index_constraint; end CONSTRAINT_Pkg; -- End: SCCONSTRAINT bdy ----------------------------------------------------- :::::::::::::: scconstra.spc :::::::::::::: -- Begin: SCCONSTRAINT spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package CONSTRAINT_Pkg is procedure Scan_CONSTRAINT(Root : CONSTRAINT.Locator); procedure Scan_RANGE_CONSTRAINT_CLASS(Root : RANGE_CONSTRAINT_CLASS.Locator); procedure Scan_range_attribute_constraint(Root : range_attribute_constraintNode.Locator); procedure Scan_range_constraint(Root : range_constraintNode.Locator); procedure Scan_REAL_CONSTRAINT(Root : REAL_CONSTRAINT.Locator); procedure Scan_fixed_constraint(Root : fixed_constraintNode.Locator); procedure Scan_float_constraint(Root : float_constraintNode.Locator); procedure Scan_apply_constraint(Root : apply_constraintNode.Locator); procedure Scan_dscrmt_constraint(Root : dscrmt_constraintNode.Locator); procedure Scan_index_constraint(Root : index_constraintNode.Locator); end CONSTRAINT_Pkg; -- End: SCCONSTRAINT spc ----------------------------------------------------- :::::::::::::: scdef_id.bdy :::::::::::::: --VMS file: %nosc.work.tools.halstead.source*(SCDEF_ID.bdy) --UTS file: /nosccomp/byron/_vms//nosc/work/tools/halstead/COMP/SCDEF_ID.bdy -- Begin: SCDEF_ID bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with variable_decl_IH; with type_decl_IH; with Identifier_Utilities; package body DEF_ID_Pkg is procedure Scan_DEF_ID(Root : DEF_ID.Locator) is begin case Kind(Root) is when ATTRIBUTE_IDKind => Scan_ATTRIBUTE_ID(Root); when BUILT_IN_OPERATORKind => Scan_BUILT_IN_OPERATOR(Root); when GENERAL_TYPE_IDKind => Scan_GENERAL_TYPE_ID(Root); when LITERAL_IDKind => Scan_LITERAL_ID(Root); when OBJECT_IDKind => Scan_OBJECT_ID(Root); when PKG_ID_CLASSKind => Scan_PKG_ID_CLASS(Root); when PRAGMA_IDKind => Scan_PRAGMA_ID(Root); when STM_IDKind => Scan_STM_ID(Root); when SUBP_IDKind => Scan_SUBP_ID(Root); when argument_idKind => Scan_argument_id(Root); when exception_idKind => Scan_exception_id(Root); when iteration_idKind => Scan_iteration_id(Root); when number_idKind => Scan_number_id(Root); when subtype_idKind => Scan_subtype_id(Root); when task_body_idKind => Scan_task_body_id(Root); when others => null; end case; end Scan_DEF_ID; procedure Scan_ATTRIBUTE_ID(Root : ATTRIBUTE_ID.Locator) is begin case Kind(Root) is when LRM_ATTRIBUTE_IDKind => Scan_LRM_ATTRIBUTE_ID(Root); when others => null; end case; end Scan_ATTRIBUTE_ID; procedure Scan_LRM_ATTRIBUTE_ID(Root : LRM_ATTRIBUTE_ID.Locator) is begin case Kind(Root) is when address_idKind => Scan_address_id(Root); when aft_idKind => Scan_aft_id(Root); when base_idKind => Scan_base_id(Root); when callable_idKind => Scan_callable_id(Root); when constrained_idKind => Scan_constrained_id(Root); when count_idKind => Scan_count_id(Root); when delta_idKind => Scan_delta_id(Root); when digits_idKind => Scan_digits_id(Root); when emax_idKind => Scan_emax_id(Root); when epsilon_idKind => Scan_epsilon_id(Root); when first_bit_idKind => Scan_first_bit_id(Root); when first_index_idKind => Scan_first_index_id(Root); when first_scalar_idKind => Scan_first_scalar_id(Root); when fore_idKind => Scan_fore_id(Root); when image_idKind => Scan_image_id(Root); when large_idKind => Scan_large_id(Root); when last_bit_idKind => Scan_last_bit_id(Root); when last_index_idKind => Scan_last_index_id(Root); when last_scalar_idKind => Scan_last_scalar_id(Root); when length_idKind => Scan_length_id(Root); when machine_emax_idKind => Scan_machine_emax_id(Root); when machine_emin_idKind => Scan_machine_emin_id(Root); when machine_mantissa_idKind => Scan_machine_mantissa_id(Root); when machine_overflows_idKind => Scan_machine_overflows_id(Root); when machine_radix_idKind => Scan_machine_radix_id(Root); when machine_rounds_idKind => Scan_machine_rounds_id(Root); when mantissa_idKind => Scan_mantissa_id(Root); when pos_idKind => Scan_pos_id(Root); when position_idKind => Scan_position_id(Root); when pred_idKind => Scan_pred_id(Root); when range_idKind => Scan_range_id(Root); when safe_emax_idKind => Scan_safe_emax_id(Root); when safe_large_idKind => Scan_safe_large_id(Root); when safe_small_idKind => Scan_safe_small_id(Root); when size_objects_idKind => Scan_size_objects_id(Root); when size_type_idKind => Scan_size_type_id(Root); when small_idKind => Scan_small_id(Root); when storage_size_collection_idKind => Scan_storage_size_collection_id(Root); when storage_size_task_idKind => Scan_storage_size_task_id(Root); when succ_idKind => Scan_succ_id(Root); when terminated_idKind => Scan_terminated_id(Root); when val_idKind => Scan_val_id(Root); when value_idKind => Scan_value_id(Root); when width_idKind => Scan_width_id(Root); when others => null; end case; end Scan_LRM_ATTRIBUTE_ID; procedure Scan_address_id(Root : address_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_address_id; procedure Scan_aft_id(Root : aft_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_aft_id; procedure Scan_base_id(Root : base_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_base_id; procedure Scan_callable_id(Root : callable_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_callable_id; procedure Scan_constrained_id(Root : constrained_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_constrained_id; procedure Scan_count_id(Root : count_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_count_id; procedure Scan_delta_id(Root : delta_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_delta_id; procedure Scan_digits_id(Root : digits_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_digits_id; procedure Scan_emax_id(Root : emax_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_emax_id; procedure Scan_epsilon_id(Root : epsilon_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_epsilon_id; procedure Scan_first_bit_id(Root : first_bit_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_first_bit_id; procedure Scan_first_index_id(Root : first_index_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_first_index_id; procedure Scan_first_scalar_id(Root : first_scalar_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_first_scalar_id; procedure Scan_fore_id(Root : fore_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_fore_id; procedure Scan_image_id(Root : image_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_image_id; procedure Scan_large_id(Root : large_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_large_id; procedure Scan_last_bit_id(Root : last_bit_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_last_bit_id; procedure Scan_last_index_id(Root : last_index_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_last_index_id; procedure Scan_last_scalar_id(Root : last_scalar_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_last_scalar_id; procedure Scan_length_id(Root : length_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_length_id; procedure Scan_machine_emax_id(Root : machine_emax_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_emax_id; procedure Scan_machine_emin_id(Root : machine_emin_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_emin_id; procedure Scan_machine_mantissa_id(Root : machine_mantissa_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_mantissa_id; procedure Scan_machine_overflows_id(Root : machine_overflows_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_overflows_id; procedure Scan_machine_radix_id(Root : machine_radix_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_radix_id; procedure Scan_machine_rounds_id(Root : machine_rounds_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_machine_rounds_id; procedure Scan_mantissa_id(Root : mantissa_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_mantissa_id; procedure Scan_pos_id(Root : pos_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_pos_id; procedure Scan_position_id(Root : position_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_position_id; procedure Scan_pred_id(Root : pred_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_pred_id; procedure Scan_range_id(Root : range_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_range_id; procedure Scan_safe_emax_id(Root : safe_emax_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_safe_emax_id; procedure Scan_safe_large_id(Root : safe_large_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_safe_large_id; procedure Scan_safe_small_id(Root : safe_small_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_safe_small_id; procedure Scan_size_objects_id(Root : size_objects_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_size_objects_id; procedure Scan_size_type_id(Root : size_type_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_size_type_id; procedure Scan_small_id(Root : small_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_small_id; procedure Scan_storage_size_collection_id(Root : storage_size_collection_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_storage_size_collection_id; procedure Scan_storage_size_task_id(Root : storage_size_task_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_storage_size_task_id; procedure Scan_succ_id(Root : succ_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_succ_id; procedure Scan_terminated_id(Root : terminated_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_terminated_id; procedure Scan_val_id(Root : val_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_val_id; procedure Scan_value_id(Root : value_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_value_id; procedure Scan_width_id(Root : width_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_width_id; procedure Scan_BUILT_IN_OPERATOR(Root : BUILT_IN_OPERATOR.Locator) is begin case Kind(Root) is when built_in_absKind => Scan_built_in_abs(Root); when built_in_andKind => Scan_built_in_and(Root); when built_in_modKind => Scan_built_in_mod(Root); when built_in_notKind => Scan_built_in_not(Root); when built_in_orKind => Scan_built_in_or(Root); when built_in_remKind => Scan_built_in_rem(Root); when built_in_xorKind => Scan_built_in_xor(Root); when concatenateKind => Scan_concatenate(Root); when divideKind => Scan_divide(Root); when equalKind => Scan_equal(Root); when exponentKind => Scan_exponent(Root); when greater_thanKind => Scan_greater_than(Root); when greater_than_or_equalKind => Scan_greater_than_or_equal(Root); when less_thanKind => Scan_less_than(Root); when less_than_or_equalKind => Scan_less_than_or_equal(Root); when minusKind => Scan_minus(Root); when multiplyKind => Scan_multiply(Root); when negateKind => Scan_negate(Root); when not_equalKind => Scan_not_equal(Root); when plusKind => Scan_plus(Root); when unary_plusKind => Scan_unary_plus(Root); when others => null; end case; end Scan_BUILT_IN_OPERATOR; procedure Scan_built_in_abs(Root : built_in_absNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_abs; procedure Scan_built_in_and(Root : built_in_andNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_and; procedure Scan_built_in_mod(Root : built_in_modNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_mod; procedure Scan_built_in_not(Root : built_in_notNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_not; procedure Scan_built_in_or(Root : built_in_orNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_or; procedure Scan_built_in_rem(Root : built_in_remNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_rem; procedure Scan_built_in_xor(Root : built_in_xorNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_built_in_xor; procedure Scan_concatenate(Root : concatenateNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_concatenate; procedure Scan_divide(Root : divideNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_divide; procedure Scan_equal(Root : equalNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_equal; procedure Scan_exponent(Root : exponentNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_exponent; procedure Scan_greater_than(Root : greater_thanNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_greater_than; procedure Scan_greater_than_or_equal(Root : greater_than_or_equalNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_greater_than_or_equal; procedure Scan_less_than(Root : less_thanNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_less_than; procedure Scan_less_than_or_equal(Root : less_than_or_equalNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_less_than_or_equal; procedure Scan_minus(Root : minusNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_minus; procedure Scan_multiply(Root : multiplyNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_multiply; procedure Scan_negate(Root : negateNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_negate; procedure Scan_not_equal(Root : not_equalNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_not_equal; procedure Scan_plus(Root : plusNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_plus; procedure Scan_unary_plus(Root : unary_plusNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_unary_plus; procedure Scan_GENERAL_TYPE_ID(Root : GENERAL_TYPE_ID.Locator) is begin case Kind(Root) is when lim_priv_type_idKind => Scan_lim_priv_type_id(Root); when priv_type_idKind => Scan_priv_type_id(Root); when type_idKind => Scan_type_id(Root); when others => null; end case; end Scan_GENERAL_TYPE_ID; procedure Scan_lim_priv_type_id(Root : lim_priv_type_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_lim_priv_type_id; procedure Scan_priv_type_id(Root : priv_type_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_priv_type_id; procedure Scan_type_id(Root : type_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_type_id; procedure Scan_LITERAL_ID(Root : LITERAL_ID.Locator) is begin case Kind(Root) is when def_charKind => Scan_def_char(Root); when enum_idKind => Scan_enum_id(Root); when others => null; end case; end Scan_LITERAL_ID; procedure Scan_def_char(Root : def_charNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_def_char; procedure Scan_enum_id(Root : enum_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_enum_id; procedure Scan_OBJECT_ID(Root : OBJECT_ID.Locator) is begin case Kind(Root) is when PARAM_IDKind => Scan_PARAM_ID(Root); when component_idKind => Scan_component_id(Root); when constant_idKind => Scan_constant_id(Root); when dscrmt_idKind => Scan_dscrmt_id(Root); when variable_idKind => Scan_variable_id(Root); when others => null; end case; end Scan_OBJECT_ID; procedure Scan_PARAM_ID(Root : PARAM_ID.Locator) is begin case Kind(Root) is when in_idKind => Scan_in_id(Root); when in_out_idKind => Scan_in_out_id(Root); when out_idKind => Scan_out_id(Root); when others => null; end case; end Scan_PARAM_ID; procedure Scan_in_id(Root : in_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_in_id; procedure Scan_in_out_id(Root : in_out_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_in_out_id; procedure Scan_out_id(Root : out_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_out_id; procedure Scan_component_id(Root : component_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_component_id; procedure Scan_constant_id(Root : constant_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_constant_id; procedure Scan_dscrmt_id(Root : dscrmt_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_dscrmt_id; procedure Scan_variable_id(Root : variable_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_variable_id; procedure Scan_PKG_ID_CLASS(Root : PKG_ID_CLASS.Locator) is begin case Kind(Root) is when generic_pkg_idKind => Scan_generic_pkg_id(Root); when pkg_idKind => Scan_pkg_id(Root); when others => null; end case; end Scan_PKG_ID_CLASS; procedure Scan_generic_pkg_id(Root : generic_pkg_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_generic_pkg_id; procedure Scan_pkg_id(Root : pkg_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_pkg_id; procedure Scan_PRAGMA_ID(Root : PRAGMA_ID.Locator) is begin case Kind(Root) is when AIE_PRAGMA_IDKind => Scan_AIE_PRAGMA_ID(Root); when LRM_PRAGMA_IDKind => Scan_LRM_PRAGMA_ID(Root); when others => null; end case; end Scan_PRAGMA_ID; procedure Scan_AIE_PRAGMA_ID(Root : AIE_PRAGMA_ID.Locator) is begin case Kind(Root) is when link_name_pragmaKind => Scan_link_name_pragma(Root); when mark_release_pragmaKind => Scan_mark_release_pragma(Root); when monitor_pragmaKind => Scan_monitor_pragma(Root); when unrecognized_pragmaKind => Scan_unrecognized_pragma(Root); when others => null; end case; end Scan_AIE_PRAGMA_ID; procedure Scan_link_name_pragma(Root : link_name_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_link_name_pragma; procedure Scan_mark_release_pragma(Root : mark_release_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_mark_release_pragma; procedure Scan_monitor_pragma(Root : monitor_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_monitor_pragma; procedure Scan_unrecognized_pragma(Root : unrecognized_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_unrecognized_pragma; procedure Scan_LRM_PRAGMA_ID(Root : LRM_PRAGMA_ID.Locator) is begin case Kind(Root) is when controlled_pragmaKind => Scan_controlled_pragma(Root); when elaborate_pragmaKind => Scan_elaborate_pragma(Root); when inline_pragmaKind => Scan_inline_pragma(Root); when interface_pragmaKind => Scan_interface_pragma(Root); when list_pragmaKind => Scan_list_pragma(Root); when memory_size_pragmaKind => Scan_memory_size_pragma(Root); when optimize_pragmaKind => Scan_optimize_pragma(Root); when pack_pragmaKind => Scan_pack_pragma(Root); when page_pragmaKind => Scan_page_pragma(Root); when priority_pragmaKind => Scan_priority_pragma(Root); when shared_pragmaKind => Scan_shared_pragma(Root); when storage_unit_pragmaKind => Scan_storage_unit_pragma(Root); when suppress_pragmaKind => Scan_suppress_pragma(Root); when system_name_pragmaKind => Scan_system_name_pragma(Root); when others => null; end case; end Scan_LRM_PRAGMA_ID; procedure Scan_controlled_pragma(Root : controlled_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_controlled_pragma; procedure Scan_elaborate_pragma(Root : elaborate_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_elaborate_pragma; procedure Scan_inline_pragma(Root : inline_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_inline_pragma; procedure Scan_interface_pragma(Root : interface_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_interface_pragma; procedure Scan_list_pragma(Root : list_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_list_pragma; procedure Scan_memory_size_pragma(Root : memory_size_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_memory_size_pragma; procedure Scan_optimize_pragma(Root : optimize_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_optimize_pragma; procedure Scan_pack_pragma(Root : pack_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_pack_pragma; procedure Scan_page_pragma(Root : page_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_page_pragma; procedure Scan_priority_pragma(Root : priority_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_priority_pragma; procedure Scan_shared_pragma(Root : shared_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_shared_pragma; procedure Scan_storage_unit_pragma(Root : storage_unit_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_storage_unit_pragma; procedure Scan_suppress_pragma(Root : suppress_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_suppress_pragma; procedure Scan_system_name_pragma(Root : system_name_pragmaNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_system_name_pragma; procedure Scan_STM_ID(Root : STM_ID.Locator) is begin case Kind(Root) is when block_idKind => Scan_block_id(Root); when label_idKind => Scan_label_id(Root); when loop_idKind => Scan_loop_id(Root); when others => null; end case; end Scan_STM_ID; procedure Scan_block_id(Root : block_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_block_id; procedure Scan_label_id(Root : label_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_label_id; procedure Scan_loop_id(Root : loop_idNode.Locator) is begin IncrementToken (colonz); if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_loop_id; procedure Scan_SUBP_ID(Root : SUBP_ID.Locator) is begin case Kind(Root) is when GENERIC_SUBP_IDKind => Scan_GENERIC_SUBP_ID(Root); when def_operatorKind => Scan_def_operator(Root); when entry_idKind => Scan_entry_id(Root); when func_idKind => Scan_func_id(Root); when proc_idKind => Scan_proc_id(Root); when others => null; end case; end Scan_SUBP_ID; procedure Scan_GENERIC_SUBP_ID(Root : GENERIC_SUBP_ID.Locator) is begin case Kind(Root) is when generic_func_idKind => Scan_generic_func_id(Root); when generic_proc_idKind => Scan_generic_proc_id(Root); when others => null; end case; end Scan_GENERIC_SUBP_ID; procedure Scan_generic_func_id(Root : generic_func_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_generic_func_id; procedure Scan_generic_proc_id(Root : generic_proc_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_generic_proc_id; procedure Scan_def_operator(Root : def_operatorNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_def_operator; procedure Scan_entry_id(Root : entry_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_entry_id; procedure Scan_func_id(Root : func_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_func_id; procedure Scan_proc_id(Root : proc_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_proc_id; procedure Scan_argument_id(Root : argument_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_argument_id; procedure Scan_exception_id(Root : exception_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_exception_id; procedure Scan_iteration_id(Root : iteration_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_iteration_id; procedure Scan_number_id(Root : number_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_number_id; procedure Scan_subtype_id(Root : subtype_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_subtype_id; procedure Scan_task_body_id(Root : task_body_idNode.Locator) is begin if not Identifier_Utilities.Is_Id_Null (root) then DEF_ID_Set.Insert (root, CurrentBlock.SetOfDEF_IDs); end if; end Scan_task_body_id; end DEF_ID_Pkg; -- End: SCDEF_ID bdy ----------------------------------------------------- :::::::::::::: scdef_id.spc :::::::::::::: -- Begin: SCDEF_ID spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package DEF_ID_Pkg is procedure Scan_DEF_ID(Root : DEF_ID.Locator); procedure Scan_ATTRIBUTE_ID(Root : ATTRIBUTE_ID.Locator); procedure Scan_LRM_ATTRIBUTE_ID(Root : LRM_ATTRIBUTE_ID.Locator); procedure Scan_address_id(Root : address_idNode.Locator); procedure Scan_aft_id(Root : aft_idNode.Locator); procedure Scan_base_id(Root : base_idNode.Locator); procedure Scan_callable_id(Root : callable_idNode.Locator); procedure Scan_constrained_id(Root : constrained_idNode.Locator); procedure Scan_count_id(Root : count_idNode.Locator); procedure Scan_delta_id(Root : delta_idNode.Locator); procedure Scan_digits_id(Root : digits_idNode.Locator); procedure Scan_emax_id(Root : emax_idNode.Locator); procedure Scan_epsilon_id(Root : epsilon_idNode.Locator); procedure Scan_first_bit_id(Root : first_bit_idNode.Locator); procedure Scan_first_index_id(Root : first_index_idNode.Locator); procedure Scan_first_scalar_id(Root : first_scalar_idNode.Locator); procedure Scan_fore_id(Root : fore_idNode.Locator); procedure Scan_image_id(Root : image_idNode.Locator); procedure Scan_large_id(Root : large_idNode.Locator); procedure Scan_last_bit_id(Root : last_bit_idNode.Locator); procedure Scan_last_index_id(Root : last_index_idNode.Locator); procedure Scan_last_scalar_id(Root : last_scalar_idNode.Locator); procedure Scan_length_id(Root : length_idNode.Locator); procedure Scan_machine_emax_id(Root : machine_emax_idNode.Locator); procedure Scan_machine_emin_id(Root : machine_emin_idNode.Locator); procedure Scan_machine_mantissa_id(Root : machine_mantissa_idNode.Locator); procedure Scan_machine_overflows_id(Root : machine_overflows_idNode.Locator); procedure Scan_machine_radix_id(Root : machine_radix_idNode.Locator); procedure Scan_machine_rounds_id(Root : machine_rounds_idNode.Locator); procedure Scan_mantissa_id(Root : mantissa_idNode.Locator); procedure Scan_pos_id(Root : pos_idNode.Locator); procedure Scan_position_id(Root : position_idNode.Locator); procedure Scan_pred_id(Root : pred_idNode.Locator); procedure Scan_range_id(Root : range_idNode.Locator); procedure Scan_safe_emax_id(Root : safe_emax_idNode.Locator); procedure Scan_safe_large_id(Root : safe_large_idNode.Locator); procedure Scan_safe_small_id(Root : safe_small_idNode.Locator); procedure Scan_size_objects_id(Root : size_objects_idNode.Locator); procedure Scan_size_type_id(Root : size_type_idNode.Locator); procedure Scan_small_id(Root : small_idNode.Locator); procedure Scan_storage_size_collection_id(Root : storage_size_collection_idNode.Locator); procedure Scan_storage_size_task_id(Root : storage_size_task_idNode.Locator); procedure Scan_succ_id(Root : succ_idNode.Locator); procedure Scan_terminated_id(Root : terminated_idNode.Locator); procedure Scan_val_id(Root : val_idNode.Locator); procedure Scan_value_id(Root : value_idNode.Locator); procedure Scan_width_id(Root : width_idNode.Locator); procedure Scan_BUILT_IN_OPERATOR(Root : BUILT_IN_OPERATOR.Locator); procedure Scan_built_in_abs(Root : built_in_absNode.Locator); procedure Scan_built_in_and(Root : built_in_andNode.Locator); procedure Scan_built_in_mod(Root : built_in_modNode.Locator); procedure Scan_built_in_not(Root : built_in_notNode.Locator); procedure Scan_built_in_or(Root : built_in_orNode.Locator); procedure Scan_built_in_rem(Root : built_in_remNode.Locator); procedure Scan_built_in_xor(Root : built_in_xorNode.Locator); procedure Scan_concatenate(Root : concatenateNode.Locator); procedure Scan_divide(Root : divideNode.Locator); procedure Scan_equal(Root : equalNode.Locator); procedure Scan_exponent(Root : exponentNode.Locator); procedure Scan_greater_than(Root : greater_thanNode.Locator); procedure Scan_greater_than_or_equal(Root : greater_than_or_equalNode.Locator); procedure Scan_less_than(Root : less_thanNode.Locator); procedure Scan_less_than_or_equal(Root : less_than_or_equalNode.Locator); procedure Scan_minus(Root : minusNode.Locator); procedure Scan_multiply(Root : multiplyNode.Locator); procedure Scan_negate(Root : negateNode.Locator); procedure Scan_not_equal(Root : not_equalNode.Locator); procedure Scan_plus(Root : plusNode.Locator); procedure Scan_unary_plus(Root : unary_plusNode.Locator); procedure Scan_GENERAL_TYPE_ID(Root : GENERAL_TYPE_ID.Locator); procedure Scan_lim_priv_type_id(Root : lim_priv_type_idNode.Locator); procedure Scan_priv_type_id(Root : priv_type_idNode.Locator); procedure Scan_type_id(Root : type_idNode.Locator); procedure Scan_LITERAL_ID(Root : LITERAL_ID.Locator); procedure Scan_def_char(Root : def_charNode.Locator); procedure Scan_enum_id(Root : enum_idNode.Locator); procedure Scan_OBJECT_ID(Root : OBJECT_ID.Locator); procedure Scan_PARAM_ID(Root : PARAM_ID.Locator); procedure Scan_in_id(Root : in_idNode.Locator); procedure Scan_in_out_id(Root : in_out_idNode.Locator); procedure Scan_out_id(Root : out_idNode.Locator); procedure Scan_component_id(Root : component_idNode.Locator); procedure Scan_constant_id(Root : constant_idNode.Locator); procedure Scan_dscrmt_id(Root : dscrmt_idNode.Locator); procedure Scan_variable_id(Root : variable_idNode.Locator); procedure Scan_PKG_ID_CLASS(Root : PKG_ID_CLASS.Locator); procedure Scan_generic_pkg_id(Root : generic_pkg_idNode.Locator); procedure Scan_pkg_id(Root : pkg_idNode.Locator); procedure Scan_PRAGMA_ID(Root : PRAGMA_ID.Locator); procedure Scan_AIE_PRAGMA_ID(Root : AIE_PRAGMA_ID.Locator); procedure Scan_link_name_pragma(Root : link_name_pragmaNode.Locator); procedure Scan_mark_release_pragma(Root : mark_release_pragmaNode.Locator); procedure Scan_monitor_pragma(Root : monitor_pragmaNode.Locator); procedure Scan_unrecognized_pragma(Root : unrecognized_pragmaNode.Locator); procedure Scan_LRM_PRAGMA_ID(Root : LRM_PRAGMA_ID.Locator); procedure Scan_controlled_pragma(Root : controlled_pragmaNode.Locator); procedure Scan_elaborate_pragma(Root : elaborate_pragmaNode.Locator); procedure Scan_inline_pragma(Root : inline_pragmaNode.Locator); procedure Scan_interface_pragma(Root : interface_pragmaNode.Locator); procedure Scan_list_pragma(Root : list_pragmaNode.Locator); procedure Scan_memory_size_pragma(Root : memory_size_pragmaNode.Locator); procedure Scan_optimize_pragma(Root : optimize_pragmaNode.Locator); procedure Scan_pack_pragma(Root : pack_pragmaNode.Locator); procedure Scan_page_pragma(Root : page_pragmaNode.Locator); procedure Scan_priority_pragma(Root : priority_pragmaNode.Locator); procedure Scan_shared_pragma(Root : shared_pragmaNode.Locator); procedure Scan_storage_unit_pragma(Root : storage_unit_pragmaNode.Locator); procedure Scan_suppress_pragma(Root : suppress_pragmaNode.Locator); procedure Scan_system_name_pragma(Root : system_name_pragmaNode.Locator); procedure Scan_STM_ID(Root : STM_ID.Locator); procedure Scan_block_id(Root : block_idNode.Locator); procedure Scan_label_id(Root : label_idNode.Locator); procedure Scan_loop_id(Root : loop_idNode.Locator); procedure Scan_SUBP_ID(Root : SUBP_ID.Locator); procedure Scan_GENERIC_SUBP_ID(Root : GENERIC_SUBP_ID.Locator); procedure Scan_generic_func_id(Root : generic_func_idNode.Locator); procedure Scan_generic_proc_id(Root : generic_proc_idNode.Locator); procedure Scan_def_operator(Root : def_operatorNode.Locator); procedure Scan_entry_id(Root : entry_idNode.Locator); procedure Scan_func_id(Root : func_idNode.Locator); procedure Scan_proc_id(Root : proc_idNode.Locator); procedure Scan_argument_id(Root : argument_idNode.Locator); procedure Scan_exception_id(Root : exception_idNode.Locator); procedure Scan_iteration_id(Root : iteration_idNode.Locator); procedure Scan_number_id(Root : number_idNode.Locator); procedure Scan_subtype_id(Root : subtype_idNode.Locator); procedure Scan_task_body_id(Root : task_body_idNode.Locator); end DEF_ID_Pkg; -- End: SCDEF_ID spc ----------------------------------------------------- :::::::::::::: scgeneral.bdy :::::::::::::: -- Begin: SCGENERAL_ASSOC bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; package body GENERAL_ASSOC_Pkg is procedure Scan_GENERAL_ASSOC(Root : GENERAL_ASSOC.Locator) is begin case Kind(Root) is when GA_ASSOC_EXPKind => Scan_GA_ASSOC_EXP(Root); when ga_rangeKind => Scan_ga_range(Root); when others => null; end case; end Scan_GENERAL_ASSOC; procedure Scan_GA_ASSOC_EXP(Root : GA_ASSOC_EXP.Locator) is begin case Kind(Root) is when ga_assocKind => Scan_ga_assoc(Root); when ga_expKind => Scan_ga_exp(Root); when others => null; end case; end Scan_GA_ASSOC_EXP; procedure Scan_ga_assoc(Root : ga_assocNode.Locator) is as_id_s_List : SeqOfused_idNode.Generator; as_id_s_Item : used_idNode.Locator; use SeqOfused_idNode; begin if not SeqOfused_idNode.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); Scan_used_id(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); end if; if not NAME_EXP.IsNull(as_exp(Root)) then Scan_NAME_EXP(as_exp(Root)); end if; end Scan_ga_assoc; procedure Scan_ga_exp(Root : ga_expNode.Locator) is begin if not NAME_EXP.IsNull(as_exp(Root)) then Scan_NAME_EXP(as_exp(Root)); end if; end Scan_ga_exp; procedure Scan_ga_range(Root : ga_rangeNode.Locator) is begin if not OBJECT_TYPE.IsNull(as_apply_discrete_range(Root)) then Scan_OBJECT_TYPE(as_apply_discrete_range(Root)); end if; end Scan_ga_range; end GENERAL_ASSOC_Pkg; -- End: SCGENERAL_ASSOC bdy ----------------------------------------------------- :::::::::::::: scgeneral.spc :::::::::::::: -- Begin: SCGENERAL_ASSOC spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package GENERAL_ASSOC_Pkg is procedure Scan_GENERAL_ASSOC(Root : GENERAL_ASSOC.Locator); procedure Scan_GA_ASSOC_EXP(Root : GA_ASSOC_EXP.Locator); procedure Scan_ga_assoc(Root : ga_assocNode.Locator); procedure Scan_ga_exp(Root : ga_expNode.Locator); procedure Scan_ga_range(Root : ga_rangeNode.Locator); end GENERAL_ASSOC_Pkg; -- End: SCGENERAL_ASSOC spc ----------------------------------------------------- :::::::::::::: scgeneric.bdy :::::::::::::: -- Begin: SCGENERIC_HEADER_CLASS bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with generic_header_IH; with ITEM_Pkg; use ITEM_Pkg; package body GENERIC_HEADER_CLASS_Pkg is procedure Scan_GENERIC_HEADER_CLASS(Root : GENERIC_HEADER_CLASS.Locator) is begin case Kind(Root) is when generic_headerKind => Scan_generic_header(Root); when others => null; end case; end Scan_GENERIC_HEADER_CLASS; procedure Scan_generic_header(Root : generic_headerNode.Locator) is as_generic_param_s_List : SeqOfITEM.Generator; as_generic_param_s_Item : ITEM.Locator; use SeqOfITEM; Old_generic_header_IHR : generic_header_IH.RecType := generic_header_IH.R; begin generic_header_IH.R.ih_ingeneric_param := false ; generic_header_IH.R.ih_ingeneric_param := true; if not SeqOfITEM.IsNull(as_generic_param_s(Root)) then StartForward(as_generic_param_s(Root), as_generic_param_s_List); while not Finished(as_generic_param_s_List) loop as_generic_param_s_Item := Cell(as_generic_param_s_List); IncrementToken (semicolonz); Scan_ITEM(as_generic_param_s_Item); Forward(as_generic_param_s_List); end loop; EndIterate(as_generic_param_s_List); end if; generic_header_IH.R.ih_ingeneric_param := true; generic_header_IH.R := Old_generic_header_IHR; end Scan_generic_header; end GENERIC_HEADER_CLASS_Pkg; -- End: SCGENERIC_HEADER_CLASS bdy ----------------------------------------------------- :::::::::::::: scgeneric.spc :::::::::::::: -- Begin: SCGENERIC_HEADER_CLASS spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package GENERIC_HEADER_CLASS_Pkg is procedure Scan_GENERIC_HEADER_CLASS(Root : GENERIC_HEADER_CLASS.Locator); procedure Scan_generic_header(Root : generic_headerNode.Locator); end GENERIC_HEADER_CLASS_Pkg; -- End: SCGENERIC_HEADER_CLASS spc ----------------------------------------------------- :::::::::::::: scheader.bdy :::::::::::::: -- Begin: SCHEADER bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with ITEM_Pkg; use ITEM_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with generic_header_IH; package body HEADER_Pkg is procedure Scan_HEADER(Root : HEADER.Locator) is begin case Kind(Root) is when accept_specKind => Scan_accept_spec(Root); when entry_specKind => Scan_entry_spec(Root); when func_specKind => Scan_func_spec(Root); when proc_specKind => Scan_proc_spec(Root); when others => null; end case; end Scan_HEADER; procedure Scan_accept_spec(Root : accept_specNode.Locator) is as_param_s_List : SeqOfOBJECT_ITEM.Generator; as_param_s_Item : OBJECT_ITEM.Locator; use SeqOfOBJECT_ITEM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (open_parenthesisz); end if; if not NAME_EXP.IsNull(as_family_index(Root)) then IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_family_index(Root)); IncrementToken (closed_parenthesisz); end if; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then StartForward(as_param_s(Root), as_param_s_List); while not Finished(as_param_s_List) loop as_param_s_Item := Cell(as_param_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (semicolonz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_OBJECT_ITEM(as_param_s_Item); Forward(as_param_s_List); end loop; EndIterate(as_param_s_List); if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_accept_spec; procedure Scan_entry_spec(Root : entry_specNode.Locator) is as_param_s_List : SeqOfOBJECT_ITEM.Generator; as_param_s_Item : OBJECT_ITEM.Locator; use SeqOfOBJECT_ITEM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (open_parenthesisz); end if; if not OBJECT_TYPE.IsNull(as_family_range_void(Root)) then IncrementToken (open_parenthesisz); Scan_OBJECT_TYPE(as_family_range_void(Root)); IncrementToken (closed_parenthesisz); end if; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then StartForward(as_param_s(Root), as_param_s_List); while not Finished(as_param_s_List) loop as_param_s_Item := Cell(as_param_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (semicolonz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_OBJECT_ITEM(as_param_s_Item); Forward(as_param_s_List); end loop; EndIterate(as_param_s_List); if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_entry_spec; procedure Scan_func_spec(Root : func_specNode.Locator) is as_param_s_List : SeqOfOBJECT_ITEM.Generator; as_param_s_Item : OBJECT_ITEM.Locator; use SeqOfOBJECT_ITEM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (open_parenthesisz); end if; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then StartForward(as_param_s(Root), as_param_s_List); while not Finished(as_param_s_List) loop as_param_s_Item := Cell(as_param_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (semicolonz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_OBJECT_ITEM(as_param_s_Item); Forward(as_param_s_List); end loop; EndIterate(as_param_s_List); if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; end if; if not object_type_constrainedNode.IsNull(as_return_type(Root)) then IncrementToken (returnz); Scan_object_type_constrained(as_return_type(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_func_spec; procedure Scan_proc_spec(Root : proc_specNode.Locator) is as_param_s_List : SeqOfOBJECT_ITEM.Generator; as_param_s_Item : OBJECT_ITEM.Locator; use SeqOfOBJECT_ITEM; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (open_parenthesisz); end if; if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then StartForward(as_param_s(Root), as_param_s_List); while not Finished(as_param_s_List) loop as_param_s_Item := Cell(as_param_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (semicolonz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_OBJECT_ITEM(as_param_s_Item); Forward(as_param_s_List); end loop; EndIterate(as_param_s_List); if not SeqOfOBJECT_ITEM.IsNull(as_param_s(Root)) then IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_proc_spec; end HEADER_Pkg; -- End: SCHEADER bdy ----------------------------------------------------- :::::::::::::: scheader.spc :::::::::::::: -- Begin: SCHEADER spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package HEADER_Pkg is procedure Scan_HEADER(Root : HEADER.Locator); procedure Scan_accept_spec(Root : accept_specNode.Locator); procedure Scan_entry_spec(Root : entry_specNode.Locator); procedure Scan_func_spec(Root : func_specNode.Locator); procedure Scan_proc_spec(Root : proc_specNode.Locator); end HEADER_Pkg; -- End: SCHEADER spc ----------------------------------------------------- :::::::::::::: scinner_r.bdy :::::::::::::: -- Begin: SCINNER_RECORD_CLASS bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with inner_record_IH; with ITEM_Pkg; use ITEM_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with VARIANT_ALTERNATIVE_CLASS_Pkg; use VARIANT_ALTERNATIVE_CLASS_Pkg; package body INNER_RECORD_CLASS_Pkg is procedure Scan_INNER_RECORD_CLASS(Root : INNER_RECORD_CLASS.Locator) is begin case Kind(Root) is when inner_recordKind => Scan_inner_record(Root); when others => null; end case; end Scan_INNER_RECORD_CLASS; procedure Scan_inner_record(Root : inner_recordNode.Locator) is as_list_List : SeqOfITEM.Generator; as_list_Item : ITEM.Locator; use SeqOfITEM; as_variant_s_List : SeqOfvariant_alternativeNode.Generator; as_variant_s_Item : variant_alternativeNode.Locator; use SeqOfvariant_alternativeNode; as_trailing_pragma_s_List : SeqOfpragma_declNode.Generator; as_trailing_pragma_s_Item : pragma_declNode.Locator; use SeqOfpragma_declNode; Old_inner_record_IHR : inner_record_IH.RecType := inner_record_IH.R; begin inner_record_IH.R.ih_in_variant := false ; if not SeqOfITEM.IsNull(as_list(Root)) then StartForward(as_list(Root), as_list_List); while not Finished(as_list_List) loop as_list_Item := Cell(as_list_List); Scan_ITEM(as_list_Item); Forward(as_list_List); end loop; EndIterate(as_list_List); end if; if not NAME_EXP.IsNull(as_variant_name(Root)) then IncrementToken (case_variantz); inner_record_IH.R.ih_in_variant := true; Scan_NAME_EXP(as_variant_name(Root)); IncrementToken (is_case_variantz); end if; if not SeqOfvariant_alternativeNode.IsNull(as_variant_s(Root)) then StartForward(as_variant_s(Root), as_variant_s_List); while not Finished(as_variant_s_List) loop as_variant_s_Item := Cell(as_variant_s_List); Scan_variant_alternative(as_variant_s_Item); Forward(as_variant_s_List); end loop; EndIterate(as_variant_s_List); IncrementToken (end_case_variantz); IncrementToken (case_variantz); IncrementToken (semicolonz); inner_record_IH.R.ih_in_variant := false; end if; if not SeqOfpragma_declNode.IsNull(as_trailing_pragma_s(Root)) then StartForward(as_trailing_pragma_s(Root), as_trailing_pragma_s_List); while not Finished(as_trailing_pragma_s_List) loop as_trailing_pragma_s_Item := Cell(as_trailing_pragma_s_List); Scan_pragma_decl(as_trailing_pragma_s_Item); Forward(as_trailing_pragma_s_List); end loop; EndIterate(as_trailing_pragma_s_List); end if; inner_record_IH.R := Old_inner_record_IHR; end Scan_inner_record; end INNER_RECORD_CLASS_Pkg; -- End: SCINNER_RECORD_CLASS bdy ----------------------------------------------------- :::::::::::::: scinner_r.spc :::::::::::::: -- Begin: SCINNER_RECORD_CLASS spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package INNER_RECORD_CLASS_Pkg is procedure Scan_INNER_RECORD_CLASS(Root : INNER_RECORD_CLASS.Locator); procedure Scan_inner_record(Root : inner_recordNode.Locator); end INNER_RECORD_CLASS_Pkg; -- End: SCINNER_RECORD_CLASS spc ----------------------------------------------------- :::::::::::::: scitem.bdy :::::::::::::: -- Begin: SCITEM bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with variable_decl_IH; with subtype_decl_IH; with task_decl_IH; with type_decl_IH; with GENERIC_HEADER_CLASS_Pkg; use GENERIC_HEADER_CLASS_Pkg; with DEF_ID_Pkg; use DEF_ID_Pkg; with PKG_DEF_Pkg; use PKG_DEF_Pkg; with HEADER_Pkg; use HEADER_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with OBJECT_DEF_Pkg; use OBJECT_DEF_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with CONSTRAINT_Pkg; use CONSTRAINT_Pkg; with SUBP_DEF_Pkg; use SUBP_DEF_Pkg; with GENERAL_ASSOC_Pkg; use GENERAL_ASSOC_Pkg; with BLOCK_STUB_Pkg; use BLOCK_STUB_Pkg; with TYPE_SPEC_Pkg; use TYPE_SPEC_Pkg; with variable_decl_IH; with type_decl_IH; with generic_header_IH; package body ITEM_Pkg is procedure Scan_ITEM(Root : ITEM.Locator) is begin case Kind(Root) is when GENERIC_ITEMKind => Scan_GENERIC_ITEM(Root); when OBJECT_ITEMKind => Scan_OBJECT_ITEM(Root); when PKG_ITEMKind => Scan_PKG_ITEM(Root); when REP_SPECKind => Scan_REP_SPEC(Root); when SUBP_ITEMKind => Scan_SUBP_ITEM(Root); when entry_declKind => Scan_entry_decl(Root); when exception_declKind => Scan_exception_decl(Root); when null_componentKind => Scan_null_component(Root); when number_declKind => Scan_number_decl(Root); when pragma_declKind => Scan_pragma_decl(Root); when subtype_declKind => Scan_subtype_decl(Root); when subunitKind => Scan_subunit(Root); when task_bodyKind => Scan_task_body(Root); when task_declKind => Scan_task_decl(Root); when type_declKind => Scan_type_decl(Root); when use_clauseKind => Scan_use_clause(Root); when with_clauseKind => Scan_with_clause(Root); when others => null; end case; end Scan_ITEM; procedure Scan_GENERIC_ITEM(Root : GENERIC_ITEM.Locator) is begin case Kind(Root) is when generic_pkg_declKind => Scan_generic_pkg_decl(Root); when generic_subp_declKind => Scan_generic_subp_decl(Root); when others => null; end case; end Scan_GENERIC_ITEM; procedure Scan_generic_pkg_decl(Root : generic_pkg_declNode.Locator) is begin if not GENERIC_HEADER_CLASS.IsNull(as_generic_spec(Root)) then Scan_GENERIC_HEADER_CLASS(as_generic_spec(Root)); end if; if not DEF_ID.IsNull(as_generic_id(Root)) then if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; SetBlockId (lx_symrep (as_generic_id (root)), package_spec_block, SpcId, LineNumber (lx_srcpos (root)) ); IncrementToken (genericz); IncrementToken (package_spcz); IncrementToken (is_package_spcz); IncrementToken (end_package_spcz); IncrementToken (semicolonz); Scan_DEF_ID(as_generic_id(Root)); end if; if not pkg_specNode.IsNull(as_generic_pkg_spec(Root)) then Scan_pkg_spec(as_generic_pkg_spec(Root)); end if; end Scan_generic_pkg_decl; procedure Scan_generic_subp_decl(Root : generic_subp_declNode.Locator) is begin if not GENERIC_HEADER_CLASS.IsNull(as_generic_spec(Root)) then Scan_GENERIC_HEADER_CLASS(as_generic_spec(Root)); end if; if not DEF_ID.IsNull(as_generic_id(Root)) then IncrementToken (genericz); if Kind (as_generic_id (root)) in generic_proc_idKind then IncrementToken (procedurez); else IncrementToken (functionz); end if; Scan_DEF_ID(as_generic_id(Root)); end if; if not HEADER.IsNull(as_generic_subp_spec(Root)) then Scan_HEADER(as_generic_subp_spec(Root)); end if; IncrementToken (semicolonz); end Scan_generic_subp_decl; procedure Scan_OBJECT_ITEM(Root : OBJECT_ITEM.Locator) is begin case Kind(Root) is when component_declKind => Scan_component_decl(Root); when constant_declKind => Scan_constant_decl(Root); when dscrmt_declKind => Scan_dscrmt_decl(Root); when in_declKind => Scan_in_decl(Root); when in_out_declKind => Scan_in_out_decl(Root); when out_declKind => Scan_out_decl(Root); when variable_declKind => Scan_variable_decl(Root); when others => null; end case; end Scan_OBJECT_ITEM; procedure Scan_component_decl(Root : component_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; IncrementToken (semicolonz); SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_component_decl; procedure Scan_constant_decl(Root : constant_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then IncrementToken (constantz); Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; IncrementToken (semicolonz); SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_constant_decl; procedure Scan_dscrmt_decl(Root : dscrmt_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_dscrmt_decl; procedure Scan_in_decl(Root : in_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then if lx_explicit_in_decl (root) then IncrementToken (in_parameterz); end if; Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_in_decl; procedure Scan_in_out_decl(Root : in_out_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then IncrementToken (in_out_parameterz); Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_in_out_decl; procedure Scan_out_decl(Root : out_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then IncrementToken (outz); Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_out_decl; procedure Scan_variable_decl(Root : variable_declNode.Locator) is as_id_s_List : SeqOfDEF_ID.Generator; as_id_s_Item : DEF_ID.Locator; use SeqOfDEF_ID; Old_variable_decl_IHR : variable_decl_IH.RecType := variable_decl_IH.R; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin variable_decl_IH.R.ih_init := false ; SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfDEF_ID.IsNull(as_id_s(Root)) then StartForward(as_id_s(Root), as_id_s_List); while not Finished(as_id_s_List) loop as_id_s_Item := Cell(as_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_DEF_ID(as_id_s_Item); Forward(as_id_s_List); end loop; EndIterate(as_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not OBJECT_TYPE.IsNull(as_object_type(Root)) then Scan_OBJECT_TYPE(as_object_type(Root)); end if; if not OBJECT_DEF.IsNull(as_object_def(Root)) then Scan_OBJECT_DEF(as_object_def(Root)); end if; IncrementToken (semicolonz); variable_decl_IH.R := Old_variable_decl_IHR; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_variable_decl; procedure Scan_PKG_ITEM(Root : PKG_ITEM.Locator) is begin case Kind(Root) is when pkg_bodyKind => Scan_pkg_body(Root); when pkg_declKind => Scan_pkg_decl(Root); when others => null; end case; end Scan_PKG_ITEM; procedure Scan_pkg_body(Root : pkg_bodyNode.Locator) is begin if not pkg_idNode.IsNull(as_pkg_id(Root)) then Scan_pkg_id(as_pkg_id(Root)); if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; SetBlockId (lx_symrep (as_pkg_id (root)), package_body_block, BdyId, LineNumber (lx_srcpos (root)) ); IncrementToken (package_bdyz); IncrementToken (body_packagez); IncrementToken (is_package_bdyz); end if; if not PKG_DEF.IsNull(as_pkg_def(Root)) then Scan_PKG_DEF(as_pkg_def(Root)); end if; if Kind (as_pkg_def (root)) not in pkg_instantiationKind then IncrementToken (semicolonz); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); end if; end Scan_pkg_body; procedure Scan_pkg_decl(Root : pkg_declNode.Locator) is begin if not pkg_idNode.IsNull(as_pkg_id(Root)) then Scan_pkg_id(as_pkg_id(Root)); if Kind (as_pkg_def (root)) not in pkg_instantiationKind then if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; SetBlockId (lx_symrep (as_pkg_id (root)), package_spec_block, SpcId, LineNumber (lx_srcpos (root)) ); IncrementToken (end_package_spcz); end if; IncrementToken (package_spcz); IncrementToken (is_package_spcz); end if; if not PKG_DEF.IsNull(as_pkg_def(Root)) then Scan_PKG_DEF(as_pkg_def(Root)); end if; if Kind (as_pkg_def (root)) not in pkg_instantiationKind then IncrementToken (semicolonz); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); end if; end Scan_pkg_decl; procedure Scan_REP_SPEC(Root : REP_SPEC.Locator) is begin case Kind(Root) is when address_repKind => Scan_address_rep(Root); when record_repKind => Scan_record_rep(Root); when rep_componentKind => Scan_rep_component(Root); when simple_repKind => Scan_simple_rep(Root); when others => null; end case; end Scan_REP_SPEC; procedure Scan_address_rep(Root : address_repNode.Locator) is begin if not NAME_EXP.IsNull(as_rep_name(Root)) then IncrementToken (for_repz); Scan_NAME_EXP(as_rep_name(Root)); IncrementToken (use_repz); IncrementToken (atz); IncrementToken (semicolonz); end if; if not NAME_EXP.IsNull(as_address_rep_exp(Root)) then Scan_NAME_EXP(as_address_rep_exp(Root)); end if; end Scan_address_rep; procedure Scan_record_rep(Root : record_repNode.Locator) is as_components_List : SeqOfrep_componentNode.Generator; as_components_Item : rep_componentNode.Locator; use SeqOfrep_componentNode; begin if not NAME_EXP.IsNull(as_rep_name(Root)) then IncrementToken (for_repz); Scan_NAME_EXP(as_rep_name(Root)); IncrementToken (use_repz); IncrementToken (record_repz); end if; if not NAME_EXP.IsNull(as_record_alignment(Root)) then IncrementToken (atz); IncrementToken (modz); Scan_NAME_EXP(as_record_alignment(Root)); end if; if not SeqOfrep_componentNode.IsNull(as_components(Root)) then StartForward(as_components(Root), as_components_List); while not Finished(as_components_List) loop as_components_Item := Cell(as_components_List); Scan_rep_component(as_components_Item); Forward(as_components_List); end loop; EndIterate(as_components_List); IncrementToken (end_record_repz); IncrementToken (record_repz); IncrementToken (semicolonz); end if; end Scan_record_rep; procedure Scan_rep_component(Root : rep_componentNode.Locator) is begin if not NAME_EXP.IsNull(as_rep_name(Root)) then Scan_NAME_EXP(as_rep_name(Root)); IncrementToken (atz); end if; if not RANGE_CONSTRAINT_CLASS.IsNull(as_alignment_range(Root)) then IncrementToken (rangez); Scan_RANGE_CONSTRAINT_CLASS(as_alignment_range(Root)); end if; if not NAME_EXP.IsNull(as_rep_component_exp(Root)) then Scan_NAME_EXP(as_rep_component_exp(Root)); end if; end Scan_rep_component; procedure Scan_simple_rep(Root : simple_repNode.Locator) is begin if not NAME_EXP.IsNull(as_rep_name(Root)) then Scan_NAME_EXP(as_rep_name(Root)); end if; if not NAME_EXP.IsNull(as_simple_rep_exp(Root)) then IncrementToken (for_repz); Scan_NAME_EXP(as_simple_rep_exp(Root)); IncrementToken (use_repz); end if; end Scan_simple_rep; procedure Scan_SUBP_ITEM(Root : SUBP_ITEM.Locator) is begin case Kind(Root) is when subp_bodyKind => Scan_subp_body(Root); when subp_declKind => Scan_subp_decl(Root); when others => null; end case; end Scan_SUBP_ITEM; procedure Scan_subp_body(Root : subp_bodyNode.Locator) is begin if not DEF_ID.IsNull(as_subp_designator(Root)) then Scan_DEF_ID(as_subp_designator(Root)); if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; if Kind (as_subp_designator (root)) in proc_idKind then SetBlockId (lx_symrep (as_subp_designator (root)), procedure_block, BdyId, LineNumber (lx_srcpos (root)) ); IncrementToken (procedurez); IncrementToken (is_procedurez); else SetBlockId (lx_symrep (as_subp_designator (root)), function_block, BdyId, LineNumber (lx_srcpos (root)) ); IncrementToken (functionz); IncrementToken (is_functionz); end if; end if; if not HEADER.IsNull(as_subp_spec(Root)) then Scan_HEADER(as_subp_spec(Root)); end if; if not SUBP_DEF.IsNull(as_subp_def(Root)) then Scan_SUBP_DEF(as_subp_def(Root)); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); end if; end Scan_subp_body; procedure Scan_subp_decl(Root : subp_declNode.Locator) is begin if not DEF_ID.IsNull(as_subp_designator(Root)) then Scan_DEF_ID(as_subp_designator(Root)); end if; if not HEADER.IsNull(as_subp_spec(Root)) then Scan_HEADER(as_subp_spec(Root)); end if; if not SUBP_DEF.IsNull(as_subp_def(Root)) then Scan_SUBP_DEF(as_subp_def(Root)); end if; if generic_header_IH.R.ih_ingeneric_param then IncrementToken (with_genericz); end if; if Kind (as_subp_designator (root)) in proc_idKind then IncrementToken (procedurez); else IncrementToken (functionz); end if; IncrementToken (semicolonz); end Scan_subp_decl; procedure Scan_entry_decl(Root : entry_declNode.Locator) is begin IncrementToken (entryz); if not entry_idNode.IsNull(as_entry_designator(Root)) then Scan_entry_id(as_entry_designator(Root)); end if; if not entry_specNode.IsNull(as_entry_spec(Root)) then Scan_entry_spec(as_entry_spec(Root)); end if; IncrementToken (semicolonz); end Scan_entry_decl; procedure Scan_exception_decl(Root : exception_declNode.Locator) is as_exception_id_s_List : SeqOfexception_idNode.Generator; as_exception_id_s_Item : exception_idNode.Locator; use SeqOfexception_idNode; begin if not SeqOfexception_idNode.IsNull(as_exception_id_s(Root)) then StartForward(as_exception_id_s(Root), as_exception_id_s_List); while not Finished(as_exception_id_s_List) loop as_exception_id_s_Item := Cell(as_exception_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_exception_id(as_exception_id_s_Item); Forward(as_exception_id_s_List); end loop; EndIterate(as_exception_id_s_List); IncrementToken (colonz); IncrementToken (exceptionz); IncrementToken (semicolonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not NAME_EXP.IsNull(as_exception_def(Root)) then IncrementToken (renamesz); Scan_NAME_EXP(as_exception_def(Root)); end if; end Scan_exception_decl; procedure Scan_null_component(Root : null_componentNode.Locator) is begin IncrementToken (null_fieldz); IncrementToken (semicolonz); end Scan_null_component; procedure Scan_number_decl(Root : number_declNode.Locator) is as_number_id_s_List : SeqOfnumber_idNode.Generator; as_number_id_s_Item : number_idNode.Locator; use SeqOfnumber_idNode; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfnumber_idNode.IsNull(as_number_id_s(Root)) then StartForward(as_number_id_s(Root), as_number_id_s_List); while not Finished(as_number_id_s_List) loop as_number_id_s_Item := Cell(as_number_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_number_id(as_number_id_s_Item); Forward(as_number_id_s_List); end loop; EndIterate(as_number_id_s_List); IncrementToken (colonz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not NAME_EXP.IsNull(as_number_exp(Root)) then IncrementToken (constantz); IncrementToken (colon_equalsz); Scan_NAME_EXP(as_number_exp(Root)); end if; IncrementToken (semicolonz); SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_number_decl; procedure Scan_pragma_decl(Root : pragma_declNode.Locator) is as_pragma_param_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_pragma_param_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; begin IncrementToken (pragmaz); if not used_idNode.IsNull(as_pragma_id(Root)) then Scan_used_id(as_pragma_id(Root)); end if; if not SeqOfGENERAL_ASSOC.IsNull(as_pragma_param_assoc_s(Root)) then IncrementToken (open_parenthesisz); StartForward(as_pragma_param_assoc_s(Root), as_pragma_param_assoc_s_List); while not Finished(as_pragma_param_assoc_s_List) loop as_pragma_param_assoc_s_Item := Cell(as_pragma_param_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_GENERAL_ASSOC(as_pragma_param_assoc_s_Item); Forward(as_pragma_param_assoc_s_List); end loop; EndIterate(as_pragma_param_assoc_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; IncrementToken (semicolonz); end Scan_pragma_decl; procedure Scan_subtype_decl(Root : subtype_declNode.Locator) is Old_subtype_decl_IHR : subtype_decl_IH.RecType := subtype_decl_IH.R; begin subtype_decl_IH.R.ih_in_subtype_decl := false ; IncrementToken (subtypez); subtype_decl_IH.R.ih_in_subtype_decl := true; if not subtype_idNode.IsNull(as_subtype_id(Root)) then Scan_subtype_id(as_subtype_id(Root)); IncrementToken (is_subtypez); end if; if not object_type_constrainedNode.IsNull(as_subtype_constrained(Root)) then Scan_object_type_constrained(as_subtype_constrained(Root)); end if; subtype_decl_IH.R.ih_in_subtype_decl := false; IncrementToken (semicolonz); subtype_decl_IH.R := Old_subtype_decl_IHR; end Scan_subtype_decl; procedure Scan_subunit(Root : subunitNode.Locator) is begin IncrementToken (separatez); if not NAME_EXP.IsNull(as_subunit_path(Root)) then IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_subunit_path(Root)); IncrementToken (closed_parenthesisz); end if; if not ITEM.IsNull(as_subunit_body(Root)) then Scan_ITEM(as_subunit_body(Root)); end if; end Scan_subunit; procedure Scan_task_body(Root : task_bodyNode.Locator) is begin if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; SetBlockId (lx_symrep (as_task_body_id (root)), task_body_block, BdyId, LineNumber (lx_srcpos (root)) ); IncrementToken (task_bdyz); IncrementToken (body_taskz); IncrementToken (is_task_bdyz); if not task_body_idNode.IsNull(as_task_body_id(Root)) then Scan_task_body_id(as_task_body_id(Root)); end if; if not BLOCK_STUB.IsNull(as_task_body_block_stub(Root)) then Scan_BLOCK_STUB(as_task_body_block_stub(Root)); end if; IncrementToken (semicolonz); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); end Scan_task_body; procedure Scan_task_decl(Root : task_declNode.Locator) is Old_task_decl_IHR : task_decl_IH.RecType := task_decl_IH.R; begin task_decl_IH.R.ih_intask_decl := false ; task_decl_IH.R.ih_intask_decl := true; if not variable_idNode.IsNull(as_task_id(Root)) then Scan_variable_id(as_task_id(Root)); end if; if not task_specNode.IsNull(as_task_def(Root)) then Scan_task_spec(as_task_def(Root)); end if; task_decl_IH.R.ih_intask_decl := false; task_decl_IH.R := Old_task_decl_IHR; end Scan_task_decl; procedure Scan_type_decl(Root : type_declNode.Locator) is as_type_dscrmt_s_List : SeqOfdscrmt_declNode.Generator; as_type_dscrmt_s_Item : dscrmt_declNode.Locator; use SeqOfdscrmt_declNode; Old_type_decl_IHR : type_decl_IH.RecType := type_decl_IH.R; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if Kind (as_type_spec (root)) not in task_specKind then IncrementToken (typez); IncrementToken (is_typez); end if; if not type_idNode.IsNull(as_type_id(Root)) then Scan_type_id(as_type_id(Root)); end if; if not SeqOfdscrmt_declNode.IsNull(as_type_dscrmt_s(Root)) then IncrementToken (open_parenthesisz); StartForward(as_type_dscrmt_s(Root), as_type_dscrmt_s_List); while not Finished(as_type_dscrmt_s_List) loop as_type_dscrmt_s_Item := Cell(as_type_dscrmt_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (semicolonz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_dscrmt_decl(as_type_dscrmt_s_Item); Forward(as_type_dscrmt_s_List); end loop; EndIterate(as_type_dscrmt_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not TYPE_SPEC.IsNull(as_type_spec(Root)) then Scan_TYPE_SPEC(as_type_spec(Root)); end if; if Kind (as_type_spec (root)) not in task_specKind then IncrementToken (semicolonz); end if; type_decl_IH.R := Old_type_decl_IHR; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_type_decl; procedure Scan_use_clause(Root : use_clauseNode.Locator) is as_use_clause_list_List : SeqOfNAME_EXP.Generator; as_use_clause_list_Item : NAME_EXP.Locator; use SeqOfNAME_EXP; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfNAME_EXP.IsNull(as_use_clause_list(Root)) then IncrementToken (use_contextz); StartForward(as_use_clause_list(Root), as_use_clause_list_List); while not Finished(as_use_clause_list_List) loop as_use_clause_list_Item := Cell(as_use_clause_list_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_NAME_EXP(as_use_clause_list_Item); Forward(as_use_clause_list_List); end loop; EndIterate(as_use_clause_list_List); end if; IncrementToken (semicolonz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_use_clause; procedure Scan_with_clause(Root : with_clauseNode.Locator) is as_with_clause_list_List : SeqOfNAME_EXP.Generator; as_with_clause_list_Item : NAME_EXP.Locator; use SeqOfNAME_EXP; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not SeqOfNAME_EXP.IsNull(as_with_clause_list(Root)) then IncrementToken (with_contextz); StartForward(as_with_clause_list(Root), as_with_clause_list_List); while not Finished(as_with_clause_list_List) loop as_with_clause_list_Item := Cell(as_with_clause_list_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_NAME_EXP(as_with_clause_list_Item); Forward(as_with_clause_list_List); end loop; EndIterate(as_with_clause_list_List); end if; IncrementToken (semicolonz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_with_clause; end ITEM_Pkg; -- End: SCITEM bdy ----------------------------------------------------- :::::::::::::: scitem.spc :::::::::::::: -- Begin: SCITEM spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package ITEM_Pkg is procedure Scan_ITEM(Root : ITEM.Locator); procedure Scan_GENERIC_ITEM(Root : GENERIC_ITEM.Locator); procedure Scan_generic_pkg_decl(Root : generic_pkg_declNode.Locator); procedure Scan_generic_subp_decl(Root : generic_subp_declNode.Locator); procedure Scan_OBJECT_ITEM(Root : OBJECT_ITEM.Locator); procedure Scan_component_decl(Root : component_declNode.Locator); procedure Scan_constant_decl(Root : constant_declNode.Locator); procedure Scan_dscrmt_decl(Root : dscrmt_declNode.Locator); procedure Scan_in_decl(Root : in_declNode.Locator); procedure Scan_in_out_decl(Root : in_out_declNode.Locator); procedure Scan_out_decl(Root : out_declNode.Locator); procedure Scan_variable_decl(Root : variable_declNode.Locator); procedure Scan_PKG_ITEM(Root : PKG_ITEM.Locator); procedure Scan_pkg_body(Root : pkg_bodyNode.Locator); procedure Scan_pkg_decl(Root : pkg_declNode.Locator); procedure Scan_REP_SPEC(Root : REP_SPEC.Locator); procedure Scan_address_rep(Root : address_repNode.Locator); procedure Scan_record_rep(Root : record_repNode.Locator); procedure Scan_rep_component(Root : rep_componentNode.Locator); procedure Scan_simple_rep(Root : simple_repNode.Locator); procedure Scan_SUBP_ITEM(Root : SUBP_ITEM.Locator); procedure Scan_subp_body(Root : subp_bodyNode.Locator); procedure Scan_subp_decl(Root : subp_declNode.Locator); procedure Scan_entry_decl(Root : entry_declNode.Locator); procedure Scan_exception_decl(Root : exception_declNode.Locator); procedure Scan_null_component(Root : null_componentNode.Locator); procedure Scan_number_decl(Root : number_declNode.Locator); procedure Scan_pragma_decl(Root : pragma_declNode.Locator); procedure Scan_subtype_decl(Root : subtype_declNode.Locator); procedure Scan_subunit(Root : subunitNode.Locator); procedure Scan_task_body(Root : task_bodyNode.Locator); procedure Scan_task_decl(Root : task_declNode.Locator); procedure Scan_type_decl(Root : type_declNode.Locator); procedure Scan_use_clause(Root : use_clauseNode.Locator); procedure Scan_with_clause(Root : with_clauseNode.Locator); end ITEM_Pkg; -- End: SCITEM spc ----------------------------------------------------- :::::::::::::: sciterati.bdy :::::::::::::: -- Begin: SCITERATION bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with DEF_ID_Pkg; use DEF_ID_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; package body ITERATION_Pkg is procedure Scan_ITERATION(Root : ITERATION.Locator) is begin case Kind(Root) is when FOR_ITERATIONKind => Scan_FOR_ITERATION(Root); when while_iterationKind => Scan_while_iteration(Root); when others => null; end case; end Scan_ITERATION; procedure Scan_FOR_ITERATION(Root : FOR_ITERATION.Locator) is begin case Kind(Root) is when forward_iterationKind => Scan_forward_iteration(Root); when reverse_iterationKind => Scan_reverse_iteration(Root); when others => null; end case; end Scan_FOR_ITERATION; procedure Scan_forward_iteration(Root : forward_iterationNode.Locator) is begin if not iteration_idNode.IsNull(as_id(Root)) then IncrementToken (for_loopz); IncrementToken (in_loopz); Scan_iteration_id(as_id(Root)); end if; if not OBJECT_TYPE.IsNull(as_discrete_range(Root)) then Scan_OBJECT_TYPE(as_discrete_range(Root)); end if; end Scan_forward_iteration; procedure Scan_reverse_iteration(Root : reverse_iterationNode.Locator) is begin if not iteration_idNode.IsNull(as_id(Root)) then IncrementToken (for_loopz); IncrementToken (in_loopz); Scan_iteration_id(as_id(Root)); end if; if not OBJECT_TYPE.IsNull(as_discrete_range(Root)) then IncrementToken (reversez); Scan_OBJECT_TYPE(as_discrete_range(Root)); end if; end Scan_reverse_iteration; procedure Scan_while_iteration(Root : while_iterationNode.Locator) is begin if not NAME_EXP.IsNull(as_while_exp(Root)) then IncrementToken (whilez); Scan_NAME_EXP(as_while_exp(Root)); end if; end Scan_while_iteration; end ITERATION_Pkg; -- End: SCITERATION bdy ----------------------------------------------------- :::::::::::::: sciterati.spc :::::::::::::: -- Begin: SCITERATION spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package ITERATION_Pkg is procedure Scan_ITERATION(Root : ITERATION.Locator); procedure Scan_FOR_ITERATION(Root : FOR_ITERATION.Locator); procedure Scan_forward_iteration(Root : forward_iterationNode.Locator); procedure Scan_reverse_iteration(Root : reverse_iterationNode.Locator); procedure Scan_while_iteration(Root : while_iterationNode.Locator); end ITERATION_Pkg; -- End: SCITERATION spc ----------------------------------------------------- :::::::::::::: scname_ex.bdy :::::::::::::: -- Begin: SCNAME_EXP bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with AGG_COMPONENT_Pkg; use AGG_COMPONENT_Pkg; with GENERAL_ASSOC_Pkg; use GENERAL_ASSOC_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with VmmTextPkg; with TEXT_IO; package body NAME_EXP_Pkg is procedure Scan_NAME_EXP(Root : NAME_EXP.Locator) is begin case Kind(Root) is when AGGKind => Scan_AGG(Root); when ALL_COMPONENTSKind => Scan_ALL_COMPONENTS(Root); when CALLSKind => Scan_CALLS(Root); when MARKKind => Scan_MARK(Root); when MEMBERSHIP_EXPKind => Scan_MEMBERSHIP_EXP(Root); when OPERATOR_EXPKind => Scan_OPERATOR_EXP(Root); when SHORT_CIRCUIT_EXPKind => Scan_SHORT_CIRCUIT_EXP(Root); when attributeKind => Scan_attribute(Root); when attribute_indexedKind => Scan_attribute_indexed(Root); when conversionKind => Scan_conversion(Root); when family_indexedKind => Scan_family_indexed(Root); when indexedKind => Scan_indexed(Root); when init_allocatorKind => Scan_init_allocator(Root); when null_accessKind => Scan_null_access(Root); when numeric_literalKind => Scan_numeric_literal(Root); when parenthesizedKind => Scan_parenthesized(Root); when qualifiedKind => Scan_qualified(Root); when sliceKind => Scan_slice(Root); when string_literalKind => Scan_string_literal(Root); when uninit_allocatorKind => Scan_uninit_allocator(Root); when others => null; end case; end Scan_NAME_EXP; procedure Scan_AGG(Root : AGG.Locator) is begin case Kind(Root) is when apply_aggKind => Scan_apply_agg(Root); when array_aggKind => Scan_array_agg(Root); when record_aggKind => Scan_record_agg(Root); when others => null; end case; end Scan_AGG; procedure Scan_apply_agg(Root : apply_aggNode.Locator) is as_agg_s_List : SeqOfAGG_COMPONENT.Generator; as_agg_s_Item : AGG_COMPONENT.Locator; use SeqOfAGG_COMPONENT; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); StartForward(as_agg_s(Root), as_agg_s_List); while not Finished(as_agg_s_List) loop as_agg_s_Item := Cell(as_agg_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_AGG_COMPONENT(as_agg_s_Item); Forward(as_agg_s_List); end loop; EndIterate(as_agg_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_apply_agg; procedure Scan_array_agg(Root : array_aggNode.Locator) is as_agg_s_List : SeqOfAGG_COMPONENT.Generator; as_agg_s_Item : AGG_COMPONENT.Locator; use SeqOfAGG_COMPONENT; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); StartForward(as_agg_s(Root), as_agg_s_List); while not Finished(as_agg_s_List) loop as_agg_s_Item := Cell(as_agg_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_AGG_COMPONENT(as_agg_s_Item); Forward(as_agg_s_List); end loop; EndIterate(as_agg_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_array_agg; procedure Scan_record_agg(Root : record_aggNode.Locator) is as_agg_s_List : SeqOfAGG_COMPONENT.Generator; as_agg_s_Item : AGG_COMPONENT.Locator; use SeqOfAGG_COMPONENT; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); StartForward(as_agg_s(Root), as_agg_s_List); while not Finished(as_agg_s_List) loop as_agg_s_Item := Cell(as_agg_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_AGG_COMPONENT(as_agg_s_Item); Forward(as_agg_s_List); end loop; EndIterate(as_agg_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_record_agg; procedure Scan_ALL_COMPONENTS(Root : ALL_COMPONENTS.Locator) is begin case Kind(Root) is when explicit_all_componentsKind => Scan_explicit_all_components(Root); when implicit_all_componentsKind => Scan_implicit_all_components(Root); when others => null; end case; end Scan_ALL_COMPONENTS; procedure Scan_explicit_all_components(Root : explicit_all_componentsNode.Locator) is begin if not NAME_EXP.IsNull(as_all_name(Root)) then Scan_NAME_EXP(as_all_name(Root)); end if; IncrementToken (allz); IncrementToken (dotz); end Scan_explicit_all_components; procedure Scan_implicit_all_components(Root : implicit_all_componentsNode.Locator) is begin if not NAME_EXP.IsNull(as_all_name(Root)) then Scan_NAME_EXP(as_all_name(Root)); end if; end Scan_implicit_all_components; procedure Scan_CALLS(Root : CALLS.Locator) is begin case Kind(Root) is when apply_callKind => Scan_apply_call(Root); when entry_callKind => Scan_entry_call(Root); when func_callKind => Scan_func_call(Root); when proc_callKind => Scan_proc_call(Root); when others => null; end case; end Scan_CALLS; procedure Scan_apply_call(Root : apply_callNode.Locator) is as_param_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_param_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_apply_name(Root)) then Scan_NAME_EXP(as_apply_name(Root)); if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then IncrementToken (open_parenthesisz); end if; end if; if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then StartForward(as_param_assoc_s(Root), as_param_assoc_s_List); while not Finished(as_param_assoc_s_List) loop as_param_assoc_s_Item := Cell(as_param_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_GENERAL_ASSOC(as_param_assoc_s_Item); Forward(as_param_assoc_s_List); end loop; EndIterate(as_param_assoc_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_apply_call; procedure Scan_entry_call(Root : entry_callNode.Locator) is as_param_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_param_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_apply_name(Root)) then Scan_NAME_EXP(as_apply_name(Root)); if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then IncrementToken (open_parenthesisz); end if; end if; if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then StartForward(as_param_assoc_s(Root), as_param_assoc_s_List); while not Finished(as_param_assoc_s_List) loop as_param_assoc_s_Item := Cell(as_param_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_GENERAL_ASSOC(as_param_assoc_s_Item); Forward(as_param_assoc_s_List); end loop; EndIterate(as_param_assoc_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_entry_call; procedure Scan_func_call(Root : func_callNode.Locator) is as_param_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_param_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_apply_name(Root)) then Scan_NAME_EXP(as_apply_name(Root)); if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then IncrementToken (open_parenthesisz); end if; end if; if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then StartForward(as_param_assoc_s(Root), as_param_assoc_s_List); while not Finished(as_param_assoc_s_List) loop as_param_assoc_s_Item := Cell(as_param_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_GENERAL_ASSOC(as_param_assoc_s_Item); Forward(as_param_assoc_s_List); end loop; EndIterate(as_param_assoc_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_func_call; procedure Scan_proc_call(Root : proc_callNode.Locator) is as_param_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_param_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; if not NAME_EXP.IsNull(as_apply_name(Root)) then Scan_NAME_EXP(as_apply_name(Root)); if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then IncrementToken (open_parenthesisz); end if; end if; if not SeqOfGENERAL_ASSOC.IsNull(as_param_assoc_s(Root)) then StartForward(as_param_assoc_s(Root), as_param_assoc_s_List); while not Finished(as_param_assoc_s_List) loop as_param_assoc_s_Item := Cell(as_param_assoc_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_GENERAL_ASSOC(as_param_assoc_s_Item); Forward(as_param_assoc_s_List); end loop; EndIterate(as_param_assoc_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_proc_call; procedure Scan_MARK(Root : MARK.Locator) is begin case Kind(Root) is when USED_SYMBOLKind => Scan_USED_SYMBOL(Root); when selectedKind => Scan_selected(Root); when others => null; end case; end Scan_MARK; procedure Scan_USED_SYMBOL(Root : USED_SYMBOL.Locator) is begin case Kind(Root) is when used_charKind => Scan_used_char(Root); when used_idKind => Scan_used_id(Root); when used_operatorKind => Scan_used_operator(Root); when others => null; end case; end Scan_USED_SYMBOL; procedure Scan_used_char(Root : used_charNode.Locator) is begin Literal_Set.Insert (lx_text (lx_symrep (root)), CurrentBlock.SetOfLiterals); IncrementToken (single_quotez); IncrementToken (single_quotez); end Scan_used_char; procedure Scan_used_id(Root : used_idNode.Locator) is begin if not DEF_ID.IsNull (sm_def (root)) then DEF_ID_Set.Insert (sm_def (root), CurrentBlock.SetOfDEF_IDs); else TEXT_IO.Put ("?? Unexpected null sm_def: "); TEXT_IO.Put_Line ( VmmTextPkg.Value ( Source_Text.Value ( lx_text ( ne_normalized_symrep ( ne_symbol_entry_in_table ( lx_symrep ( root)))))) ); end if; end Scan_used_id; procedure Scan_used_operator(Root : used_operatorNode.Locator) is begin DEF_ID_Set.Insert (sm_def (root), CurrentBlock.SetOfDEF_IDs); end Scan_used_operator; procedure Scan_selected(Root : selectedNode.Locator) is begin if not NAME_EXP.IsNull(as_selected_name(Root)) then Scan_NAME_EXP(as_selected_name(Root)); IncrementToken (dotz); end if; if not NAME_EXP.IsNull(as_selected_designator(Root)) then Scan_NAME_EXP(as_selected_designator(Root)); end if; end Scan_selected; procedure Scan_MEMBERSHIP_EXP(Root : MEMBERSHIP_EXP.Locator) is begin case Kind(Root) is when in_expKind => Scan_in_exp(Root); when not_in_expKind => Scan_not_in_exp(Root); when others => null; end case; end Scan_MEMBERSHIP_EXP; procedure Scan_in_exp(Root : in_expNode.Locator) is begin if not NAME_EXP.IsNull(as_membership_exp(Root)) then Scan_NAME_EXP(as_membership_exp(Root)); IncrementToken (in_membershipz); end if; if not OBJECT_TYPE.IsNull(as_membership_type_range(Root)) then Scan_OBJECT_TYPE(as_membership_type_range(Root)); end if; end Scan_in_exp; procedure Scan_not_in_exp(Root : not_in_expNode.Locator) is begin if not NAME_EXP.IsNull(as_membership_exp(Root)) then Scan_NAME_EXP(as_membership_exp(Root)); IncrementToken (not_in_membershipz); IncrementToken (in_membershipz); end if; if not OBJECT_TYPE.IsNull(as_membership_type_range(Root)) then Scan_OBJECT_TYPE(as_membership_type_range(Root)); end if; end Scan_not_in_exp; procedure Scan_OPERATOR_EXP(Root : OPERATOR_EXP.Locator) is begin case Kind(Root) is when binary_operationKind => Scan_binary_operation(Root); when unary_operationKind => Scan_unary_operation(Root); when others => null; end case; end Scan_OPERATOR_EXP; procedure Scan_binary_operation(Root : binary_operationNode.Locator) is begin if not NAME_EXP.IsNull(as_left_exp(Root)) then Scan_NAME_EXP(as_left_exp(Root)); end if; if not used_operatorNode.IsNull(as_operator(Root)) then Scan_used_operator(as_operator(Root)); end if; if not NAME_EXP.IsNull(as_right_exp(Root)) then Scan_NAME_EXP(as_right_exp(Root)); end if; end Scan_binary_operation; procedure Scan_unary_operation(Root : unary_operationNode.Locator) is begin if not used_operatorNode.IsNull(as_operator(Root)) then Scan_used_operator(as_operator(Root)); end if; if not NAME_EXP.IsNull(as_right_exp(Root)) then Scan_NAME_EXP(as_right_exp(Root)); end if; end Scan_unary_operation; procedure Scan_SHORT_CIRCUIT_EXP(Root : SHORT_CIRCUIT_EXP.Locator) is begin case Kind(Root) is when and_then_expKind => Scan_and_then_exp(Root); when or_else_expKind => Scan_or_else_exp(Root); when others => null; end case; end Scan_SHORT_CIRCUIT_EXP; procedure Scan_and_then_exp(Root : and_then_expNode.Locator) is begin if not NAME_EXP.IsNull(as_short_circuit_exp1(Root)) then Scan_NAME_EXP(as_short_circuit_exp1(Root)); end if; if not NAME_EXP.IsNull(as_short_circuit_exp2(Root)) then Scan_NAME_EXP(as_short_circuit_exp2(Root)); end if; IncrementToken (and_thenz); IncrementToken (then_andz); end Scan_and_then_exp; procedure Scan_or_else_exp(Root : or_else_expNode.Locator) is begin if not NAME_EXP.IsNull(as_short_circuit_exp1(Root)) then Scan_NAME_EXP(as_short_circuit_exp1(Root)); end if; if not NAME_EXP.IsNull(as_short_circuit_exp2(Root)) then Scan_NAME_EXP(as_short_circuit_exp2(Root)); end if; IncrementToken (or_elsez); IncrementToken (else_orz); end Scan_or_else_exp; procedure Scan_attribute(Root : attributeNode.Locator) is begin if not NAME_EXP.IsNull(as_attribute_name(Root)) then Scan_NAME_EXP(as_attribute_name(Root)); IncrementToken (tickz); end if; if not NAME_EXP.IsNull(as_attribute_id(Root)) then Scan_NAME_EXP(as_attribute_id(Root)); end if; end Scan_attribute; procedure Scan_attribute_indexed(Root : attribute_indexedNode.Locator) is begin if not NAME_EXP.IsNull(as_attribute_indexed_name(Root)) then IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_attribute_indexed_name(Root)); IncrementToken (closed_parenthesisz); end if; if not NAME_EXP.IsNull(as_attribute_indexed_exp(Root)) then Scan_NAME_EXP(as_attribute_indexed_exp(Root)); end if; end Scan_attribute_indexed; procedure Scan_conversion(Root : conversionNode.Locator) is begin if not NAME_EXP.IsNull(as_conversion_name(Root)) then IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_conversion_name(Root)); IncrementToken (closed_parenthesisz); end if; if not NAME_EXP.IsNull(as_conversion_exp(Root)) then Scan_NAME_EXP(as_conversion_exp(Root)); end if; end Scan_conversion; procedure Scan_family_indexed(Root : family_indexedNode.Locator) is begin if not NAME_EXP.IsNull(as_family_index(Root)) then IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_family_index(Root)); IncrementToken (closed_parenthesisz); end if; if not NAME_EXP.IsNull(as_family_name(Root)) then Scan_NAME_EXP(as_family_name(Root)); end if; end Scan_family_indexed; procedure Scan_indexed(Root : indexedNode.Locator) is as_indexed_exp_s_List : SeqOfNAME_EXP.Generator; as_indexed_exp_s_Item : NAME_EXP.Locator; use SeqOfNAME_EXP; begin if not NAME_EXP.IsNull(as_indexed_name(Root)) then Scan_NAME_EXP(as_indexed_name(Root)); end if; if not SeqOfNAME_EXP.IsNull(as_indexed_exp_s(Root)) then IncrementToken (open_parenthesisz); StartForward(as_indexed_exp_s(Root), as_indexed_exp_s_List); while not Finished(as_indexed_exp_s_List) loop as_indexed_exp_s_Item := Cell(as_indexed_exp_s_List); Scan_NAME_EXP(as_indexed_exp_s_Item); Forward(as_indexed_exp_s_List); end loop; EndIterate(as_indexed_exp_s_List); IncrementToken (closed_parenthesisz); end if; end Scan_indexed; procedure Scan_init_allocator(Root : init_allocatorNode.Locator) is begin IncrementToken (new_allocatorz); if not qualifiedNode.IsNull(as_allocator_qualified(Root)) then Scan_qualified(as_allocator_qualified(Root)); end if; end Scan_init_allocator; procedure Scan_null_access(Root : null_accessNode.Locator) is begin IncrementToken (null_valuez); end Scan_null_access; procedure Scan_numeric_literal(Root : numeric_literalNode.Locator) is begin Literal_Set.Insert (lx_text (lx_numrep (root)), CurrentBlock.SetOfLiterals); end Scan_numeric_literal; procedure Scan_parenthesized(Root : parenthesizedNode.Locator) is begin IncrementToken (open_parenthesisz); if not NAME_EXP.IsNull(as_parenthesized_exp(Root)) then Scan_NAME_EXP(as_parenthesized_exp(Root)); end if; IncrementToken (closed_parenthesisz); end Scan_parenthesized; procedure Scan_qualified(Root : qualifiedNode.Locator) is begin if not MARK.IsNull(as_qualified_name(Root)) then Scan_MARK(as_qualified_name(Root)); IncrementToken (tickz); end if; if not NAME_EXP.IsNull(as_qualified_exp(Root)) then Scan_NAME_EXP(as_qualified_exp(Root)); end if; end Scan_qualified; procedure Scan_slice(Root : sliceNode.Locator) is begin IncrementToken (open_parenthesisz); IncrementToken (closed_parenthesisz); if not NAME_EXP.IsNull(as_slice_name(Root)) then Scan_NAME_EXP(as_slice_name(Root)); end if; if not OBJECT_TYPE.IsNull(as_slice_discrete_range(Root)) then Scan_OBJECT_TYPE(as_slice_discrete_range(Root)); end if; end Scan_slice; procedure Scan_string_literal(Root : string_literalNode.Locator) is begin IncrementToken (double_quotez); Literal_Set.Insert (lx_text (lx_string_symrep (root)), CurrentBlock.SetOfLiterals); IncrementToken (double_quotez); end Scan_string_literal; procedure Scan_uninit_allocator(Root : uninit_allocatorNode.Locator) is begin IncrementToken (new_allocatorz); if not object_type_constrainedNode.IsNull(as_allocator_constrained(Root)) then Scan_object_type_constrained(as_allocator_constrained(Root)); end if; end Scan_uninit_allocator; end NAME_EXP_Pkg; -- End: SCNAME_EXP bdy ----------------------------------------------------- :::::::::::::: scname_ex.spc :::::::::::::: -- Begin: SCNAME_EXP spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package NAME_EXP_Pkg is procedure Scan_NAME_EXP(Root : NAME_EXP.Locator); procedure Scan_AGG(Root : AGG.Locator); procedure Scan_apply_agg(Root : apply_aggNode.Locator); procedure Scan_array_agg(Root : array_aggNode.Locator); procedure Scan_record_agg(Root : record_aggNode.Locator); procedure Scan_ALL_COMPONENTS(Root : ALL_COMPONENTS.Locator); procedure Scan_explicit_all_components(Root : explicit_all_componentsNode.Locator); procedure Scan_implicit_all_components(Root : implicit_all_componentsNode.Locator); procedure Scan_CALLS(Root : CALLS.Locator); procedure Scan_apply_call(Root : apply_callNode.Locator); procedure Scan_entry_call(Root : entry_callNode.Locator); procedure Scan_func_call(Root : func_callNode.Locator); procedure Scan_proc_call(Root : proc_callNode.Locator); procedure Scan_MARK(Root : MARK.Locator); procedure Scan_USED_SYMBOL(Root : USED_SYMBOL.Locator); procedure Scan_used_char(Root : used_charNode.Locator); procedure Scan_used_id(Root : used_idNode.Locator); procedure Scan_used_operator(Root : used_operatorNode.Locator); procedure Scan_selected(Root : selectedNode.Locator); procedure Scan_MEMBERSHIP_EXP(Root : MEMBERSHIP_EXP.Locator); procedure Scan_in_exp(Root : in_expNode.Locator); procedure Scan_not_in_exp(Root : not_in_expNode.Locator); procedure Scan_OPERATOR_EXP(Root : OPERATOR_EXP.Locator); procedure Scan_binary_operation(Root : binary_operationNode.Locator); procedure Scan_unary_operation(Root : unary_operationNode.Locator); procedure Scan_SHORT_CIRCUIT_EXP(Root : SHORT_CIRCUIT_EXP.Locator); procedure Scan_and_then_exp(Root : and_then_expNode.Locator); procedure Scan_or_else_exp(Root : or_else_expNode.Locator); procedure Scan_attribute(Root : attributeNode.Locator); procedure Scan_attribute_indexed(Root : attribute_indexedNode.Locator); procedure Scan_conversion(Root : conversionNode.Locator); procedure Scan_family_indexed(Root : family_indexedNode.Locator); procedure Scan_indexed(Root : indexedNode.Locator); procedure Scan_init_allocator(Root : init_allocatorNode.Locator); procedure Scan_null_access(Root : null_accessNode.Locator); procedure Scan_numeric_literal(Root : numeric_literalNode.Locator); procedure Scan_parenthesized(Root : parenthesizedNode.Locator); procedure Scan_qualified(Root : qualifiedNode.Locator); procedure Scan_slice(Root : sliceNode.Locator); procedure Scan_string_literal(Root : string_literalNode.Locator); procedure Scan_uninit_allocator(Root : uninit_allocatorNode.Locator); end NAME_EXP_Pkg; -- End: SCNAME_EXP spc ----------------------------------------------------- :::::::::::::: scobject_.bdy :::::::::::::: -- Begin: SCOBJECT_DEF bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with NAME_EXP_Pkg; use NAME_EXP_Pkg; package body OBJECT_DEF_Pkg is procedure Scan_OBJECT_DEF(Root : OBJECT_DEF.Locator) is begin case Kind(Root) is when object_initKind => Scan_object_init(Root); when object_renameKind => Scan_object_rename(Root); when others => null; end case; end Scan_OBJECT_DEF; procedure Scan_object_init(Root : object_initNode.Locator) is begin IncrementToken (colon_equalsz); if not NAME_EXP.IsNull(as_init_exp(Root)) then Scan_NAME_EXP(as_init_exp(Root)); end if; end Scan_object_init; procedure Scan_object_rename(Root : object_renameNode.Locator) is begin IncrementToken (renamesz); if not NAME_EXP.IsNull(as_rename_name(Root)) then Scan_NAME_EXP(as_rename_name(Root)); end if; end Scan_object_rename; end OBJECT_DEF_Pkg; -- End: SCOBJECT_DEF bdy ----------------------------------------------------- :::::::::::::: scobject_.spc :::::::::::::: -- Begin: SCOBJECT_DEF spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package OBJECT_DEF_Pkg is procedure Scan_OBJECT_DEF(Root : OBJECT_DEF.Locator); procedure Scan_object_init(Root : object_initNode.Locator); procedure Scan_object_rename(Root : object_renameNode.Locator); end OBJECT_DEF_Pkg; -- End: SCOBJECT_DEF spc ----------------------------------------------------- :::::::::::::: scpkg_def.bdy :::::::::::::: -- Begin: SCPKG_DEF bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with BLOCK_STUB_Pkg; use BLOCK_STUB_Pkg; with GENERAL_ASSOC_Pkg; use GENERAL_ASSOC_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with ITEM_Pkg; use ITEM_Pkg; package body PKG_DEF_Pkg is procedure Scan_PKG_DEF(Root : PKG_DEF.Locator) is begin case Kind(Root) is when pkg_block_stubKind => Scan_pkg_block_stub(Root); when pkg_instantiationKind => Scan_pkg_instantiation(Root); when pkg_renameKind => Scan_pkg_rename(Root); when pkg_specKind => Scan_pkg_spec(Root); when others => null; end case; end Scan_PKG_DEF; procedure Scan_pkg_block_stub(Root : pkg_block_stubNode.Locator) is begin if not BLOCK_STUB.IsNull(as_pkg_block_stub(Root)) then Scan_BLOCK_STUB(as_pkg_block_stub(Root)); end if; end Scan_pkg_block_stub; procedure Scan_pkg_instantiation(Root : pkg_instantiationNode.Locator) is as_generic_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_generic_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; begin if not SeqOfGENERAL_ASSOC.IsNull(as_generic_assoc_s(Root)) then IncrementToken (open_parenthesisz); StartForward(as_generic_assoc_s(Root), as_generic_assoc_s_List); while not Finished(as_generic_assoc_s_List) loop as_generic_assoc_s_Item := Cell(as_generic_assoc_s_List); Scan_GENERAL_ASSOC(as_generic_assoc_s_Item); Forward(as_generic_assoc_s_List); end loop; EndIterate(as_generic_assoc_s_List); IncrementToken (closed_parenthesisz); end if; if not NAME_EXP.IsNull(as_instantiation_name(Root)) then Scan_NAME_EXP(as_instantiation_name(Root)); IncrementToken (new_generic_instz); end if; end Scan_pkg_instantiation; procedure Scan_pkg_rename(Root : pkg_renameNode.Locator) is begin IncrementToken (renamesz); if not NAME_EXP.IsNull(as_rename_name(Root)) then IncrementToken (renamesz); Scan_NAME_EXP(as_rename_name(Root)); end if; end Scan_pkg_rename; procedure Scan_pkg_spec(Root : pkg_specNode.Locator) is as_visible_part_List : SeqOfITEM.Generator; as_visible_part_Item : ITEM.Locator; use SeqOfITEM; as_priv_part_List : SeqOfITEM.Generator; as_priv_part_Item : ITEM.Locator; use SeqOfITEM; begin if not SeqOfITEM.IsNull(as_visible_part(Root)) then StartForward(as_visible_part(Root), as_visible_part_List); while not Finished(as_visible_part_List) loop as_visible_part_Item := Cell(as_visible_part_List); Scan_ITEM(as_visible_part_Item); Forward(as_visible_part_List); end loop; EndIterate(as_visible_part_List); end if; if not SeqOfITEM.IsNull(as_priv_part(Root)) then IncrementToken (private_sectionz); StartForward(as_priv_part(Root), as_priv_part_List); while not Finished(as_priv_part_List) loop as_priv_part_Item := Cell(as_priv_part_List); Scan_ITEM(as_priv_part_Item); Forward(as_priv_part_List); end loop; EndIterate(as_priv_part_List); end if; end Scan_pkg_spec; end PKG_DEF_Pkg; -- End: SCPKG_DEF bdy ----------------------------------------------------- :::::::::::::: scpkg_def.spc :::::::::::::: -- Begin: SCPKG_DEF spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package PKG_DEF_Pkg is procedure Scan_PKG_DEF(Root : PKG_DEF.Locator); procedure Scan_pkg_block_stub(Root : pkg_block_stubNode.Locator); procedure Scan_pkg_instantiation(Root : pkg_instantiationNode.Locator); procedure Scan_pkg_rename(Root : pkg_renameNode.Locator); procedure Scan_pkg_spec(Root : pkg_specNode.Locator); end PKG_DEF_Pkg; -- End: SCPKG_DEF spc ----------------------------------------------------- :::::::::::::: scstm.bdy :::::::::::::: --VMS file: %nosc.work.tools.halstead.source*(SCSTM.bdy) --UTS file: /nosccomp/byron/_vms//nosc/work/tools/halstead/COMP/SCSTM.bdy -- Begin: SCSTM bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with block_stm_IH; with NAME_EXP_Pkg; use NAME_EXP_Pkg; with HEADER_Pkg; use HEADER_Pkg; with DEF_ID_Pkg; use DEF_ID_Pkg; with BLOCK_STUB_Pkg; use BLOCK_STUB_Pkg; with ALTERNATIVE_Pkg; use ALTERNATIVE_Pkg; with ITERATION_Pkg; use ITERATION_Pkg; with ITEM_Pkg; use ITEM_Pkg; with TEXT_IO; use TEXT_IO; with VmmTextPkg; with Block_Utilities; package body STM_Pkg is procedure Scan_STM(Root : STM.Locator) is begin case Kind(Root) is when CALL_STMKind => Scan_CALL_STM(Root); when SELECTIVE_ENTRY_STMKind => Scan_SELECTIVE_ENTRY_STM(Root); when abort_stmKind => Scan_abort_stm(Root); when accept_stmKind => Scan_accept_stm(Root); when assign_stmKind => Scan_assign_stm(Root); when block_stmKind => Scan_block_stm(Root); when case_stmKind => Scan_case_stm(Root); when code_stmKind => Scan_code_stm(Root); when delay_stmKind => Scan_delay_stm(Root); when exit_stmKind => Scan_exit_stm(Root); when goto_stmKind => Scan_goto_stm(Root); when if_stmKind => Scan_if_stm(Root); when labeled_stmKind => Scan_labeled_stm(Root); when loop_stmKind => Scan_loop_stm(Root); when null_stmKind => Scan_null_stm(Root); when pragma_stmKind => Scan_pragma_stm(Root); when raise_stmKind => Scan_raise_stm(Root); when return_stmKind => Scan_return_stm(Root); when select_stmKind => Scan_select_stm(Root); when terminate_stmKind => Scan_terminate_stm(Root); when others => null; end case; end Scan_STM; procedure Scan_CALL_STM(Root : CALL_STM.Locator) is begin case Kind(Root) is when apply_call_stmKind => Scan_apply_call_stm(Root); when entry_call_stmKind => Scan_entry_call_stm(Root); when proc_call_stmKind => Scan_proc_call_stm(Root); when others => null; end case; end Scan_CALL_STM; procedure Scan_apply_call_stm(Root : apply_call_stmNode.Locator) is begin if not NAME_EXP.IsNull(as_call_name(Root)) then Scan_NAME_EXP(as_call_name(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_apply_call_stm; procedure Scan_entry_call_stm(Root : entry_call_stmNode.Locator) is begin if not NAME_EXP.IsNull(as_call_name(Root)) then Scan_NAME_EXP(as_call_name(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_entry_call_stm; procedure Scan_proc_call_stm(Root : proc_call_stmNode.Locator) is begin if not NAME_EXP.IsNull(as_call_name(Root)) then Scan_NAME_EXP(as_call_name(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_proc_call_stm; procedure Scan_SELECTIVE_ENTRY_STM(Root : SELECTIVE_ENTRY_STM.Locator) is begin case Kind(Root) is when cond_entry_stmKind => Scan_cond_entry_stm(Root); when timed_entry_stmKind => Scan_timed_entry_stm(Root); when others => null; end case; end Scan_SELECTIVE_ENTRY_STM; procedure Scan_cond_entry_stm(Root : cond_entry_stmNode.Locator) is as_sel_entry_stm_s1_List : SeqOfSTM.Generator; as_sel_entry_stm_s1_Item : STM.Locator; use SeqOfSTM; as_sel_entry_stm_s2_List : SeqOfSTM.Generator; as_sel_entry_stm_s2_Item : STM.Locator; use SeqOfSTM; begin if not SeqOfSTM.IsNull(as_sel_entry_stm_s1(Root)) then IncrementToken (selectz); StartForward(as_sel_entry_stm_s1(Root), as_sel_entry_stm_s1_List); while not Finished(as_sel_entry_stm_s1_List) loop as_sel_entry_stm_s1_Item := Cell(as_sel_entry_stm_s1_List); Scan_STM(as_sel_entry_stm_s1_Item); Forward(as_sel_entry_stm_s1_List); end loop; EndIterate(as_sel_entry_stm_s1_List); end if; if not SeqOfSTM.IsNull(as_sel_entry_stm_s2(Root)) then IncrementToken (elsez); StartForward(as_sel_entry_stm_s2(Root), as_sel_entry_stm_s2_List); while not Finished(as_sel_entry_stm_s2_List) loop as_sel_entry_stm_s2_Item := Cell(as_sel_entry_stm_s2_List); Scan_STM(as_sel_entry_stm_s2_Item); Forward(as_sel_entry_stm_s2_List); end loop; EndIterate(as_sel_entry_stm_s2_List); IncrementToken (end_selectz); IncrementToken (selectz); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_cond_entry_stm; procedure Scan_timed_entry_stm(Root : timed_entry_stmNode.Locator) is as_sel_entry_stm_s1_List : SeqOfSTM.Generator; as_sel_entry_stm_s1_Item : STM.Locator; use SeqOfSTM; as_sel_entry_stm_s2_List : SeqOfSTM.Generator; as_sel_entry_stm_s2_Item : STM.Locator; use SeqOfSTM; begin if not SeqOfSTM.IsNull(as_sel_entry_stm_s1(Root)) then IncrementToken (selectz); StartForward(as_sel_entry_stm_s1(Root), as_sel_entry_stm_s1_List); while not Finished(as_sel_entry_stm_s1_List) loop as_sel_entry_stm_s1_Item := Cell(as_sel_entry_stm_s1_List); Scan_STM(as_sel_entry_stm_s1_Item); Forward(as_sel_entry_stm_s1_List); end loop; EndIterate(as_sel_entry_stm_s1_List); end if; if not SeqOfSTM.IsNull(as_sel_entry_stm_s2(Root)) then IncrementToken (or_selectz); StartForward(as_sel_entry_stm_s2(Root), as_sel_entry_stm_s2_List); while not Finished(as_sel_entry_stm_s2_List) loop as_sel_entry_stm_s2_Item := Cell(as_sel_entry_stm_s2_List); Scan_STM(as_sel_entry_stm_s2_Item); Forward(as_sel_entry_stm_s2_List); end loop; EndIterate(as_sel_entry_stm_s2_List); IncrementToken (end_selectz); IncrementToken (selectz); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_timed_entry_stm; procedure Scan_abort_stm(Root : abort_stmNode.Locator) is as_abort_name_s_List : SeqOfNAME_EXP.Generator; as_abort_name_s_Item : NAME_EXP.Locator; use SeqOfNAME_EXP; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (abortz); if not SeqOfNAME_EXP.IsNull(as_abort_name_s(Root)) then StartForward(as_abort_name_s(Root), as_abort_name_s_List); while not Finished(as_abort_name_s_List) loop as_abort_name_s_Item := Cell(as_abort_name_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_NAME_EXP(as_abort_name_s_Item); Forward(as_abort_name_s_List); end loop; EndIterate(as_abort_name_s_List); end if; SERIES_UNIT_IH.R.ih_inlist := false; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_abort_stm; procedure Scan_accept_stm(Root : accept_stmNode.Locator) is as_accept_stm_s_List : SeqOfSTM.Generator; as_accept_stm_s_Item : STM.Locator; use SeqOfSTM; begin IncrementToken (acceptz); if not NAME_EXP.IsNull(as_accept_designator(Root)) then Scan_NAME_EXP(as_accept_designator(Root)); end if; if not accept_specNode.IsNull(as_accept_spec(Root)) then Scan_accept_spec(as_accept_spec(Root)); end if; if not SeqOfSTM.IsNull(as_accept_stm_s(Root)) then IncrementToken (doz); IncrementToken (end_acceptz); StartForward(as_accept_stm_s(Root), as_accept_stm_s_List); while not Finished(as_accept_stm_s_List) loop as_accept_stm_s_Item := Cell(as_accept_stm_s_List); Scan_STM(as_accept_stm_s_Item); Forward(as_accept_stm_s_List); end loop; EndIterate(as_accept_stm_s_List); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_accept_stm; procedure Scan_assign_stm(Root : assign_stmNode.Locator) is begin IncrementToken (colon_equalsz); if not NAME_EXP.IsNull(as_assign_name(Root)) then Scan_NAME_EXP(as_assign_name(Root)); end if; if not NAME_EXP.IsNull(as_assign_exp(Root)) then Scan_NAME_EXP(as_assign_exp(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_assign_stm; procedure Scan_block_stm(Root : block_stmNode.Locator) is Old_block_stm_IHR : block_stm_IH.RecType := block_stm_IH.R; begin block_stm_IH.R.ih_inblock := false ; if not block_idNode.IsNull(as_block_label(Root)) then Scan_block_id(as_block_label(Root)); end if; if not body_blockNode.IsNull(as_block_body(Root)) then if Block_Utilities.In_Declare_Block (as_block_body (root)) then block_stm_IH.R.ih_inblock := true; if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push (BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; if Block_Utilities.Is_Block_Labeled (root) then -- Count : which is associated with the block name -- here. At this point we know we have a label id and -- the colon adds to the complexity of the declare block. SetBlockId ( lx_symrep (as_block_label (root)), declare_block, DecId, LineNumber (lx_srcpos (root)) ); else SetBlockId ( TOKEN.NullRef, declare_block, DecId, LineNumber (lx_srcpos (root)) ); end if; end if; -- This next check is made regardless of whether we are in -- a block_stm with declarations or one without declarations. If -- the block has a name then it has a colon. if Block_Utilities.Is_Block_Labeled (root) then IncrementToken (colonz); end if; Scan_body_block(as_block_body(Root)); end if; if Block_Utilities.In_Declare_Block (as_block_body (root)) then IncrementToken (semicolonz); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); IncrementToken (declare_blockz); end if; block_stm_IH.R.ih_inblock := false; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; block_stm_IH.R := Old_block_stm_IHR; end Scan_block_stm; procedure Scan_case_stm(Root : case_stmNode.Locator) is as_case_alternative_s_List : SeqOfcase_alternativeNode.Generator; as_case_alternative_s_Item : case_alternativeNode.Locator; use SeqOfcase_alternativeNode; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (case_stmz); IncrementToken (case_stmz); IncrementToken (is_case_stmz); IncrementToken (end_case_stmz); if not NAME_EXP.IsNull(as_case_exp(Root)) then Scan_NAME_EXP(as_case_exp(Root)); end if; if not SeqOfcase_alternativeNode.IsNull(as_case_alternative_s(Root)) then StartForward(as_case_alternative_s(Root), as_case_alternative_s_List); while not Finished(as_case_alternative_s_List) loop as_case_alternative_s_Item := Cell(as_case_alternative_s_List); Scan_case_alternative(as_case_alternative_s_Item); Forward(as_case_alternative_s_List); end loop; EndIterate(as_case_alternative_s_List); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_case_stm; procedure Scan_code_stm(Root : code_stmNode.Locator) is begin if not qualifiedNode.IsNull(as_code_exp(Root)) then Scan_qualified(as_code_exp(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_code_stm; procedure Scan_delay_stm(Root : delay_stmNode.Locator) is begin IncrementToken (delayz); if not NAME_EXP.IsNull(as_delay_exp(Root)) then Scan_NAME_EXP(as_delay_exp(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_delay_stm; procedure Scan_exit_stm(Root : exit_stmNode.Locator) is begin IncrementToken (exitz); if not NAME_EXP.IsNull(as_exit_name_void(Root)) then Scan_NAME_EXP(as_exit_name_void(Root)); end if; if not NAME_EXP.IsNull(as_exit_exp_void(Root)) then IncrementToken (when_exitz); Scan_NAME_EXP(as_exit_exp_void(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_exit_stm; procedure Scan_goto_stm(Root : goto_stmNode.Locator) is begin IncrementToken (gotoz); if not NAME_EXP.IsNull(as_goto_name(Root)) then Scan_NAME_EXP(as_goto_name(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_goto_stm; procedure Scan_if_stm(Root : if_stmNode.Locator) is as_if_list_List : SeqOfcond_alternativeNode.Generator; as_if_list_Item : cond_alternativeNode.Locator; use SeqOfcond_alternativeNode; begin IncrementToken (ifz); IncrementToken (ifz); IncrementToken (end_ifz); if not SeqOfcond_alternativeNode.IsNull(as_if_list(Root)) then StartForward(as_if_list(Root), as_if_list_List); while not Finished(as_if_list_List) loop as_if_list_Item := Cell(as_if_list_List); Scan_cond_alternative(as_if_list_Item); Forward(as_if_list_List); end loop; EndIterate(as_if_list_List); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_if_stm; procedure Scan_labeled_stm(Root : labeled_stmNode.Locator) is as_labeled_id_s_List : SeqOflabel_idNode.Generator; as_labeled_id_s_Item : label_idNode.Locator; use SeqOflabel_idNode; begin IncrementToken (open_anglesz); if not SeqOflabel_idNode.IsNull(as_labeled_id_s(Root)) then StartForward(as_labeled_id_s(Root), as_labeled_id_s_List); while not Finished(as_labeled_id_s_List) loop as_labeled_id_s_Item := Cell(as_labeled_id_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (open_anglesz); IncrementToken (closed_anglesz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_label_id(as_labeled_id_s_Item); Forward(as_labeled_id_s_List); end loop; EndIterate(as_labeled_id_s_List); end if; if not STM.IsNull(as_labeled_stm(Root)) then Scan_STM(as_labeled_stm(Root)); end if; IncrementToken (closed_anglesz); SERIES_UNIT_IH.R.ih_inlist := false; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_labeled_stm; procedure Scan_loop_stm(Root : loop_stmNode.Locator) is as_loop_stm_s_List : SeqOfSTM.Generator; as_loop_stm_s_Item : STM.Locator; use SeqOfSTM; begin IncrementToken (loopz); IncrementToken (loopz); IncrementToken (end_loopz); if not ITERATION.IsNull(as_iteration(Root)) then Scan_ITERATION(as_iteration(Root)); end if; if not loop_idNode.IsNull(as_loop_label(Root)) then Scan_loop_id(as_loop_label(Root)); end if; if not SeqOfSTM.IsNull(as_loop_stm_s(Root)) then StartForward(as_loop_stm_s(Root), as_loop_stm_s_List); while not Finished(as_loop_stm_s_List) loop as_loop_stm_s_Item := Cell(as_loop_stm_s_List); Scan_STM(as_loop_stm_s_Item); Forward(as_loop_stm_s_List); end loop; EndIterate(as_loop_stm_s_List); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_loop_stm; procedure Scan_null_stm(Root : null_stmNode.Locator) is begin IncrementToken (null_stmz); if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_null_stm; procedure Scan_pragma_stm(Root : pragma_stmNode.Locator) is begin if not pragma_declNode.IsNull(as_pragma(Root)) then Scan_pragma_decl(as_pragma(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_pragma_stm; procedure Scan_raise_stm(Root : raise_stmNode.Locator) is begin IncrementToken (raisez); if not NAME_EXP.IsNull(as_raise_name_void(Root)) then Scan_NAME_EXP(as_raise_name_void(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_raise_stm; procedure Scan_return_stm(Root : return_stmNode.Locator) is begin IncrementToken (returnz); if not NAME_EXP.IsNull(as_return_exp_void(Root)) then Scan_NAME_EXP(as_return_exp_void(Root)); end if; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_return_stm; procedure Scan_select_stm(Root : select_stmNode.Locator) is as_select_clause_s_List : SeqOfselect_alternativeNode.Generator; as_select_clause_s_Item : select_alternativeNode.Locator; use SeqOfselect_alternativeNode; begin IncrementToken (selectz); IncrementToken (selectz); IncrementToken (end_selectz); if not SeqOfselect_alternativeNode.IsNull(as_select_clause_s(Root)) then StartForward(as_select_clause_s(Root), as_select_clause_s_List); while not Finished(as_select_clause_s_List) loop as_select_clause_s_Item := Cell(as_select_clause_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (or_selectz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_select_alternative(as_select_clause_s_Item); Forward(as_select_clause_s_List); end loop; EndIterate(as_select_clause_s_List); end if; if not cond_alternativeNode.IsNull(as_select_else(Root)) then Scan_cond_alternative(as_select_else(Root)); IncrementToken (elsez); end if; SERIES_UNIT_IH.R.ih_inlist := false; if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_select_stm; procedure Scan_terminate_stm(Root : terminate_stmNode.Locator) is begin IncrementToken (terminatez); if Kind(root) not in labeled_stmKind then if (not (Kind (root) in block_stmKind)) or else (not (Block_Utilities.In_Declare_Block (as_block_body (root)))) then -- If the root is not a block_stm or if it is then -- if it is not a block with declarations increment -- semicolon. -- This is because the semicolon associated with a declare -- block must be counted in that declare block. If we -- counted it here it would increment the count for the -- enclosing block. IncrementToken (semicolonz); end if; end if; end Scan_terminate_stm; end STM_Pkg; -- End: SCSTM bdy ----------------------------------------------------- :::::::::::::: scstm.spc :::::::::::::: -- Begin: SCSTM spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package STM_Pkg is procedure Scan_STM(Root : STM.Locator); procedure Scan_CALL_STM(Root : CALL_STM.Locator); procedure Scan_apply_call_stm(Root : apply_call_stmNode.Locator); procedure Scan_entry_call_stm(Root : entry_call_stmNode.Locator); procedure Scan_proc_call_stm(Root : proc_call_stmNode.Locator); procedure Scan_SELECTIVE_ENTRY_STM(Root : SELECTIVE_ENTRY_STM.Locator); procedure Scan_cond_entry_stm(Root : cond_entry_stmNode.Locator); procedure Scan_timed_entry_stm(Root : timed_entry_stmNode.Locator); procedure Scan_abort_stm(Root : abort_stmNode.Locator); procedure Scan_accept_stm(Root : accept_stmNode.Locator); procedure Scan_assign_stm(Root : assign_stmNode.Locator); procedure Scan_block_stm(Root : block_stmNode.Locator); procedure Scan_case_stm(Root : case_stmNode.Locator); procedure Scan_code_stm(Root : code_stmNode.Locator); procedure Scan_delay_stm(Root : delay_stmNode.Locator); procedure Scan_exit_stm(Root : exit_stmNode.Locator); procedure Scan_goto_stm(Root : goto_stmNode.Locator); procedure Scan_if_stm(Root : if_stmNode.Locator); procedure Scan_labeled_stm(Root : labeled_stmNode.Locator); procedure Scan_loop_stm(Root : loop_stmNode.Locator); procedure Scan_null_stm(Root : null_stmNode.Locator); procedure Scan_pragma_stm(Root : pragma_stmNode.Locator); procedure Scan_raise_stm(Root : raise_stmNode.Locator); procedure Scan_return_stm(Root : return_stmNode.Locator); procedure Scan_select_stm(Root : select_stmNode.Locator); procedure Scan_terminate_stm(Root : terminate_stmNode.Locator); end STM_Pkg; -- End: SCSTM spc ----------------------------------------------------- :::::::::::::: scsubp_de.bdy :::::::::::::: -- Begin: SCSUBP_DEF bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with BLOCK_STUB_Pkg; use BLOCK_STUB_Pkg; with GENERAL_ASSOC_Pkg; use GENERAL_ASSOC_Pkg; with NAME_EXP_Pkg; use NAME_EXP_Pkg; package body SUBP_DEF_Pkg is procedure Scan_SUBP_DEF(Root : SUBP_DEF.Locator) is begin case Kind(Root) is when FORMAL_SUBPKind => Scan_FORMAL_SUBP(Root); when subp_block_stubKind => Scan_subp_block_stub(Root); when subp_instantiationKind => Scan_subp_instantiation(Root); when subp_renameKind => Scan_subp_rename(Root); when others => null; end case; end Scan_SUBP_DEF; procedure Scan_FORMAL_SUBP(Root : FORMAL_SUBP.Locator) is begin case Kind(Root) is when formal_subp_boxKind => Scan_formal_subp_box(Root); when formal_subp_nameKind => Scan_formal_subp_name(Root); when others => null; end case; end Scan_FORMAL_SUBP; procedure Scan_formal_subp_box(Root : formal_subp_boxNode.Locator) is begin IncrementToken (box_default_subpz); end Scan_formal_subp_box; procedure Scan_formal_subp_name(Root : formal_subp_nameNode.Locator) is begin IncrementToken (is_procedurez); end Scan_formal_subp_name; procedure Scan_subp_block_stub(Root : subp_block_stubNode.Locator) is begin if not BLOCK_STUB.IsNull(as_subp_block_stub(Root)) then Scan_BLOCK_STUB(as_subp_block_stub(Root)); end if; IncrementToken (semicolonz); end Scan_subp_block_stub; procedure Scan_subp_instantiation(Root : subp_instantiationNode.Locator) is as_generic_assoc_s_List : SeqOfGENERAL_ASSOC.Generator; as_generic_assoc_s_Item : GENERAL_ASSOC.Locator; use SeqOfGENERAL_ASSOC; begin if not SeqOfGENERAL_ASSOC.IsNull(as_generic_assoc_s(Root)) then StartForward(as_generic_assoc_s(Root), as_generic_assoc_s_List); while not Finished(as_generic_assoc_s_List) loop as_generic_assoc_s_Item := Cell(as_generic_assoc_s_List); Scan_GENERAL_ASSOC(as_generic_assoc_s_Item); Forward(as_generic_assoc_s_List); end loop; EndIterate(as_generic_assoc_s_List); end if; if not NAME_EXP.IsNull(as_instantiation_name(Root)) then IncrementToken (is_procedurez); IncrementToken (new_generic_instz); IncrementToken (open_parenthesisz); Scan_NAME_EXP(as_instantiation_name(Root)); IncrementToken (closed_parenthesisz); end if; end Scan_subp_instantiation; procedure Scan_subp_rename(Root : subp_renameNode.Locator) is begin IncrementToken (renamesz); if not NAME_EXP.IsNull(as_rename_name(Root)) then Scan_NAME_EXP(as_rename_name(Root)); end if; end Scan_subp_rename; end SUBP_DEF_Pkg; -- End: SCSUBP_DEF bdy ----------------------------------------------------- :::::::::::::: scsubp_de.spc :::::::::::::: -- Begin: SCSUBP_DEF spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package SUBP_DEF_Pkg is procedure Scan_SUBP_DEF(Root : SUBP_DEF.Locator); procedure Scan_FORMAL_SUBP(Root : FORMAL_SUBP.Locator); procedure Scan_formal_subp_box(Root : formal_subp_boxNode.Locator); procedure Scan_formal_subp_name(Root : formal_subp_nameNode.Locator); procedure Scan_subp_block_stub(Root : subp_block_stubNode.Locator); procedure Scan_subp_instantiation(Root : subp_instantiationNode.Locator); procedure Scan_subp_rename(Root : subp_renameNode.Locator); end SUBP_DEF_Pkg; -- End: SCSUBP_DEF spc ----------------------------------------------------- :::::::::::::: sctype_sp.bdy :::::::::::::: -- Begin: SCTYPE_SPEC bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with SERIES_UNIT_IH; with CONSTRAINT_Pkg; use CONSTRAINT_Pkg; with OBJECT_TYPE_Pkg; use OBJECT_TYPE_Pkg; with INNER_RECORD_CLASS_Pkg; use INNER_RECORD_CLASS_Pkg; with DEF_ID_Pkg; use DEF_ID_Pkg; with ITEM_Pkg; use ITEM_Pkg; with task_decl_IH; package body TYPE_SPEC_Pkg is procedure Scan_TYPE_SPEC(Root : TYPE_SPEC.Locator) is begin case Kind(Root) is when ARRAY_TYPEKind => Scan_ARRAY_TYPE(Root); when DSCRMT_TYPEKind => Scan_DSCRMT_TYPE(Root); when FORMAL_SCALARKind => Scan_FORMAL_SCALAR(Root); when access_typeKind => Scan_access_type(Root); when derived_typeKind => Scan_derived_type(Root); when enum_typeKind => Scan_enum_type(Root); when fixed_typeKind => Scan_fixed_type(Root); when float_typeKind => Scan_float_type(Root); when integer_typeKind => Scan_integer_type(Root); when task_specKind => Scan_task_spec(Root); when others => null; end case; end Scan_TYPE_SPEC; procedure Scan_ARRAY_TYPE(Root : ARRAY_TYPE.Locator) is begin case Kind(Root) is when constrained_array_typeKind => Scan_constrained_array_type(Root); when unconstrained_array_typeKind => Scan_unconstrained_array_type(Root); when others => null; end case; end Scan_ARRAY_TYPE; procedure Scan_constrained_array_type(Root : constrained_array_typeNode.Locator) is begin IncrementToken (arrayz); if not index_constraintNode.IsNull(as_array_constraint(Root)) then Scan_index_constraint(as_array_constraint(Root)); end if; if not object_type_constrainedNode.IsNull(as_component_constrained(Root)) then IncrementToken (ofz); Scan_object_type_constrained(as_component_constrained(Root)); end if; end Scan_constrained_array_type; procedure Scan_unconstrained_array_type(Root : unconstrained_array_typeNode.Locator) is as_index_list_List : SeqOfobject_type_indexNode.Generator; as_index_list_Item : object_type_indexNode.Locator; use SeqOfobject_type_indexNode; begin IncrementToken (arrayz); if not SeqOfobject_type_indexNode.IsNull(as_index_list(Root)) then IncrementToken (open_parenthesisz); StartForward(as_index_list(Root), as_index_list_List); while not Finished(as_index_list_List) loop as_index_list_Item := Cell(as_index_list_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (box_rangez); IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_object_type_index(as_index_list_Item); Forward(as_index_list_List); end loop; EndIterate(as_index_list_List); IncrementToken (closed_parenthesisz); IncrementToken (box_rangez); SERIES_UNIT_IH.R.ih_inlist := false; end if; if not object_type_constrainedNode.IsNull(as_component_constrained(Root)) then IncrementToken (ofz); Scan_object_type_constrained(as_component_constrained(Root)); end if; end Scan_unconstrained_array_type; procedure Scan_DSCRMT_TYPE(Root : DSCRMT_TYPE.Locator) is begin case Kind(Root) is when PRIV_TYPEKind => Scan_PRIV_TYPE(Root); when record_typeKind => Scan_record_type(Root); when others => null; end case; end Scan_DSCRMT_TYPE; procedure Scan_PRIV_TYPE(Root : PRIV_TYPE.Locator) is begin case Kind(Root) is when FORMAL_PRIVKind => Scan_FORMAL_PRIV(Root); when lim_priv_typeKind => Scan_lim_priv_type(Root); when nonlim_priv_typeKind => Scan_nonlim_priv_type(Root); when others => null; end case; end Scan_PRIV_TYPE; procedure Scan_FORMAL_PRIV(Root : FORMAL_PRIV.Locator) is begin case Kind(Root) is when generic_lim_priv_typeKind => Scan_generic_lim_priv_type(Root); when generic_priv_typeKind => Scan_generic_priv_type(Root); when others => null; end case; end Scan_FORMAL_PRIV; procedure Scan_generic_lim_priv_type(Root : generic_lim_priv_typeNode.Locator) is begin IncrementToken (limitedz); IncrementToken (private_typez); end Scan_generic_lim_priv_type; procedure Scan_generic_priv_type(Root : generic_priv_typeNode.Locator) is begin IncrementToken (private_typez); end Scan_generic_priv_type; procedure Scan_lim_priv_type(Root : lim_priv_typeNode.Locator) is begin IncrementToken (limitedz); IncrementToken (private_typez); end Scan_lim_priv_type; procedure Scan_nonlim_priv_type(Root : nonlim_priv_typeNode.Locator) is begin IncrementToken (private_typez); end Scan_nonlim_priv_type; procedure Scan_record_type(Root : record_typeNode.Locator) is begin IncrementToken (record_typez); if not inner_recordNode.IsNull(as_inner_record(Root)) then Scan_inner_record(as_inner_record(Root)); end if; IncrementToken (end_recordz); IncrementToken (record_typez); end Scan_record_type; procedure Scan_FORMAL_SCALAR(Root : FORMAL_SCALAR.Locator) is begin case Kind(Root) is when formal_discreteKind => Scan_formal_discrete(Root); when formal_fixedKind => Scan_formal_fixed(Root); when formal_floatKind => Scan_formal_float(Root); when formal_integerKind => Scan_formal_integer(Root); when others => null; end case; end Scan_FORMAL_SCALAR; procedure Scan_formal_discrete(Root : formal_discreteNode.Locator) is begin IncrementToken (box_rangez); IncrementToken (open_parenthesisz); IncrementToken (closed_parenthesisz); end Scan_formal_discrete; procedure Scan_formal_fixed(Root : formal_fixedNode.Locator) is begin IncrementToken (box_rangez); IncrementToken (digitsz); end Scan_formal_fixed; procedure Scan_formal_float(Root : formal_floatNode.Locator) is begin IncrementToken (box_rangez); IncrementToken (deltaz); end Scan_formal_float; procedure Scan_formal_integer(Root : formal_integerNode.Locator) is begin IncrementToken (box_rangez); end Scan_formal_integer; procedure Scan_access_type(Root : access_typeNode.Locator) is begin IncrementToken (accessz); if not object_type_constrainedNode.IsNull(as_access_constrained(Root)) then Scan_object_type_constrained(as_access_constrained(Root)); end if; end Scan_access_type; procedure Scan_derived_type(Root : derived_typeNode.Locator) is begin IncrementToken (new_derived_typez); if not object_type_constrainedNode.IsNull(as_parent_constrained(Root)) then Scan_object_type_constrained(as_parent_constrained(Root)); end if; end Scan_derived_type; procedure Scan_enum_type(Root : enum_typeNode.Locator) is as_enumeral_s_List : SeqOfLITERAL_ID.Generator; as_enumeral_s_Item : LITERAL_ID.Locator; use SeqOfLITERAL_ID; Old_SERIES_UNIT_IHR : SERIES_UNIT_IH.RecType := SERIES_UNIT_IH.R; begin SERIES_UNIT_IH.R.ih_inlist := false ; IncrementToken (open_parenthesisz); StartForward(as_enumeral_s(Root), as_enumeral_s_List); while not Finished(as_enumeral_s_List) loop as_enumeral_s_Item := Cell(as_enumeral_s_List); if SERIES_UNIT_IH.R.ih_inlist then IncrementToken (commaz); end if; SERIES_UNIT_IH.R.ih_inlist := true; Scan_LITERAL_ID(as_enumeral_s_Item); Forward(as_enumeral_s_List); end loop; EndIterate(as_enumeral_s_List); IncrementToken (closed_parenthesisz); SERIES_UNIT_IH.R.ih_inlist := false; SERIES_UNIT_IH.R := Old_SERIES_UNIT_IHR; end Scan_enum_type; procedure Scan_fixed_type(Root : fixed_typeNode.Locator) is begin IncrementToken (deltaz); if not fixed_constraintNode.IsNull(as_fixed_constraint(Root)) then Scan_fixed_constraint(as_fixed_constraint(Root)); end if; end Scan_fixed_type; procedure Scan_float_type(Root : float_typeNode.Locator) is begin IncrementToken (digitsz); if not float_constraintNode.IsNull(as_float_constraint(Root)) then Scan_float_constraint(as_float_constraint(Root)); end if; end Scan_float_type; procedure Scan_integer_type(Root : integer_typeNode.Locator) is begin if not RANGE_CONSTRAINT_CLASS.IsNull(as_range_constraint(Root)) then Scan_RANGE_CONSTRAINT_CLASS(as_range_constraint(Root)); end if; end Scan_integer_type; procedure Scan_task_spec(Root : task_specNode.Locator) is as_task_spec_decl_s_List : SeqOfITEM.Generator; as_task_spec_decl_s_Item : ITEM.Locator; use SeqOfITEM; begin if not OuterMostBlockSeen then OuterMostBlockSeen := true; else BlockInfoStack.Push(BlockStack, CurrentBlock); CurrentBlock := InitializeCurrentBlock; end if; SetBlockId (lx_symrep (sm_def_of_type (root)), task_body_block, SpcId, LineNumber (lx_srcpos (root)) ); if not task_decl_IH.R.ih_intask_decl then -- If we are not in a task_decl and we are scanning task_spec -- then we are in a type_decl and the token type appears. IncrementToken (typez); end if; IncrementToken (task_spcz); IncrementToken (is_task_spcz); IncrementToken (end_task_spcz); if not SeqOfITEM.IsNull(as_task_spec_decl_s(Root)) then StartForward(as_task_spec_decl_s(Root), as_task_spec_decl_s_List); while not Finished(as_task_spec_decl_s_List) loop as_task_spec_decl_s_Item := Cell(as_task_spec_decl_s_List); Scan_ITEM(as_task_spec_decl_s_Item); Forward(as_task_spec_decl_s_List); end loop; EndIterate(as_task_spec_decl_s_List); end if; IncrementToken (semicolonz); ProcessBlockInfo (CurrentBlock); FreeSpace (CurrentBlock); BlockInfoStack.Pop(BlockStack, CurrentBlock); end Scan_task_spec; end TYPE_SPEC_Pkg; -- End: SCTYPE_SPEC bdy ----------------------------------------------------- :::::::::::::: sctype_sp.spc :::::::::::::: -- Begin: SCTYPE_SPEC spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package TYPE_SPEC_Pkg is procedure Scan_TYPE_SPEC(Root : TYPE_SPEC.Locator); procedure Scan_ARRAY_TYPE(Root : ARRAY_TYPE.Locator); procedure Scan_constrained_array_type(Root : constrained_array_typeNode.Locator); procedure Scan_unconstrained_array_type(Root : unconstrained_array_typeNode.Locator); procedure Scan_DSCRMT_TYPE(Root : DSCRMT_TYPE.Locator); procedure Scan_PRIV_TYPE(Root : PRIV_TYPE.Locator); procedure Scan_FORMAL_PRIV(Root : FORMAL_PRIV.Locator); procedure Scan_generic_lim_priv_type(Root : generic_lim_priv_typeNode.Locator); procedure Scan_generic_priv_type(Root : generic_priv_typeNode.Locator); procedure Scan_lim_priv_type(Root : lim_priv_typeNode.Locator); procedure Scan_nonlim_priv_type(Root : nonlim_priv_typeNode.Locator); procedure Scan_record_type(Root : record_typeNode.Locator); procedure Scan_FORMAL_SCALAR(Root : FORMAL_SCALAR.Locator); procedure Scan_formal_discrete(Root : formal_discreteNode.Locator); procedure Scan_formal_fixed(Root : formal_fixedNode.Locator); procedure Scan_formal_float(Root : formal_floatNode.Locator); procedure Scan_formal_integer(Root : formal_integerNode.Locator); procedure Scan_access_type(Root : access_typeNode.Locator); procedure Scan_derived_type(Root : derived_typeNode.Locator); procedure Scan_enum_type(Root : enum_typeNode.Locator); procedure Scan_fixed_type(Root : fixed_typeNode.Locator); procedure Scan_float_type(Root : float_typeNode.Locator); procedure Scan_integer_type(Root : integer_typeNode.Locator); procedure Scan_task_spec(Root : task_specNode.Locator); end TYPE_SPEC_Pkg; -- End: SCTYPE_SPEC spc ----------------------------------------------------- :::::::::::::: scvariant.bdy :::::::::::::: -- Begin: SCVARIANT_ALTERNATIVE_CLASS bdy --------------------------------------------------- with Halstead_Data_Base; use Halstead_Data_Base; with Definitions; use Definitions; with ITEM_Pkg; use ITEM_Pkg; with CHOICE_Pkg; use CHOICE_Pkg; with INNER_RECORD_CLASS_Pkg; use INNER_RECORD_CLASS_Pkg; package body VARIANT_ALTERNATIVE_CLASS_Pkg is procedure Scan_VARIANT_ALTERNATIVE_CLASS(Root : VARIANT_ALTERNATIVE_CLASS.Locator) is begin case Kind(Root) is when pragma_variantKind => Scan_pragma_variant(Root); when variant_alternativeKind => Scan_variant_alternative(Root); when others => null; end case; end Scan_VARIANT_ALTERNATIVE_CLASS; procedure Scan_pragma_variant(Root : pragma_variantNode.Locator) is begin if not pragma_declNode.IsNull(as_pragma_variant(Root)) then Scan_pragma_decl(as_pragma_variant(Root)); end if; end Scan_pragma_variant; procedure Scan_variant_alternative(Root : variant_alternativeNode.Locator) is as_variant_choice_s_List : SeqOfCHOICE.Generator; as_variant_choice_s_Item : CHOICE.Locator; use SeqOfCHOICE; begin if not SeqOfCHOICE.IsNull(as_variant_choice_s(Root)) then IncrementToken (when_case_variantz); StartForward(as_variant_choice_s(Root), as_variant_choice_s_List); while not Finished(as_variant_choice_s_List) loop as_variant_choice_s_Item := Cell(as_variant_choice_s_List); Scan_CHOICE(as_variant_choice_s_Item); Forward(as_variant_choice_s_List); end loop; EndIterate(as_variant_choice_s_List); IncrementToken (arrowz); end if; if not inner_recordNode.IsNull(as_record(Root)) then Scan_inner_record(as_record(Root)); end if; end Scan_variant_alternative; end VARIANT_ALTERNATIVE_CLASS_Pkg; -- End: SCVARIANT_ALTERNATIVE_CLASS bdy ----------------------------------------------------- :::::::::::::: scvariant.spc :::::::::::::: -- Begin: SCVARIANT_ALTERNATIVE_CLASS spc --------------------------------------------------- with ST_DIANA; use ST_DIANA; package VARIANT_ALTERNATIVE_CLASS_Pkg is procedure Scan_VARIANT_ALTERNATIVE_CLASS(Root : VARIANT_ALTERNATIVE_CLASS.Locator); procedure Scan_pragma_variant(Root : pragma_variantNode.Locator); procedure Scan_variant_alternative(Root : variant_alternativeNode.Locator); end VARIANT_ALTERNATIVE_CLASS_Pkg; -- End: SCVARIANT_ALTERNATIVE_CLASS spc ----------------------------------------------------- :::::::::::::: srcutil.bdy :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/SrcUtil.bdy,v $ -- $Revision: 1.3 $ -- $Date: 85/12/15 18:29:03 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.3 $"); package body Source_Position_Utilities is --| OVERVIEW --| This package creates one routine which checks if a --| MLSP.Source_Position is null. This is helpful --| at some points in the program scan to determine which --| tokens the source program contained. --| NOTES --| This routine should be incorporated in Halstead_Data_Base --| when the world is recompiled. -------------------------------------------------------------------------- function Is_Srcpos_Null ( Position :in MLSP.Source_Position ) return boolean is begin return (MLSP."=" (Position.first_location, 0)); end; end Source_Position_Utilities; :::::::::::::: srcutil.spc :::::::::::::: -- $Source: /nosc/work/tools/halstead/RCS/SrcUtil.spc,v $ -- $Revision: 1.1 $ -- $Date: 85/12/15 17:35:12 $ -- $Author: buddy $ --pragma revision ("$Revision: 1.1 $"); with ML_Source_Position_Pkg; package Source_Position_Utilities is --| OVERVIEW --| This package creates one routine which checks if a --| MLSP.Source_Position is null. This is helpful --| at some points in the program scan to determine which --| tokens the source program contained. --| NOTES --| This routine should be incorporated in Halstead_Data_Base --| when the world is recompiled. package MLSP renames ML_Source_Position_Pkg; -------------------------------------------------------------------------- function Is_Srcpos_Null ( Position :in MLSP.Source_Position ) return boolean; --| OVERVIEW --| This function returns true if the source position passed in --| is null. end Source_Position_Utilities;