ADA Programming Guide

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

/ ADA Programming Guide / ADA Programming Guide.iso / adatutor / csparts / csparts.src < prev

Wrap

Text File | 1996-01-30 | 442.7 KB | 11,227 lines

--:::::::::: --types.spc --:::::::::: -- *************************************************** -- * * -- * CS_Parts_Types * SPEC -- * * -- *************************************************** package CS_Parts_Types is --| Purpose --| Provide common type definitions for items in CS_Parts --| and useful conversion utilities. --| --| Initialization Exceptions (none) --| Notes --| Not all MIL-HDBK-1804 PDL annotations are --| used in this package due to its simplicity. --| No exceptions are raised in this package. --| --| Modifications --| 07/15/90 Rick Conn Initial Design and Code type BYTE is range 16#0# .. 16#FF#; for BYTE'SIZE use 8; -- ................................................... -- . . -- . CS_Parts_Types.Convert . SPEC -- . . -- ................................................... function Convert (Item : in CHARACTER) return BYTE; --| Purpose --| Convert a CHARACTER into a BYTE. -- ................................................... -- . . -- . CS_Parts_Types.Convert . SPEC -- . . -- ................................................... function Convert (Item : in INTEGER) return BYTE; --| Purpose --| Convert an INTEGER into a BYTE. If the --| INTEGER is greater than 255, only the low-order --| BYTE is converted. -- ................................................... -- . . -- . CS_Parts_Types.Convert . SPEC -- . . -- ................................................... function Convert (Item : in BYTE) return CHARACTER; --| Purpose --| Convert a BYTE into a CHARACTER. If the most --| significant bit of the BYTE is set, it is cleared --| as the CHARACTER. -- ................................................... -- . . -- . CS_Parts_Types.Convert . SPEC -- . . -- ................................................... function Convert (Item : in BYTE) return INTEGER; --| Purpose --| Convert a BYTE into a INTEGER. end CS_Parts_Types; --:::::::::: --console.spc --:::::::::: -- ********************************************************* -- * * -- * Console * SPEC -- * * -- ********************************************************* package Console is --| Purpose --| Console provides a set of I/O and screen control commands --| for either IBM PC computers employing the ANSI.SYS device --| driver or the VT100-compatible family of terminals. By using --| this package, a programmer may manipulate the terminal screen --| regardless if it is an IBM PC with ANSI.SYS or a VT100 terminal. --| --| The console object runs in one of three modes: --| TTY All screen-oriented commands are disabled --| VT100 All screen-oriented commands except display --| color control (foreground and background) --| are enabled --| ANSI All screen-oriented commands are enabled --| The default mode is TTY, and the mode of the console object --| can be changed at any time by calling the Set_Terminal --| routine. --| --| The output to the console object can be enabled or disabled --| by using the Enable_Output and Disable_Output routines. --| The Push and Pop routines can be used to preserve the current --| state of the console and restore the console to the previous --| state. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| 3/8/91 Richard Conn Initial Release Max_Number_of_States : constant NATURAL := 10; -- number of enable/disable states to the console; also, -- number of Push calls before a State_Overflow exception type TERMINAL_KIND is (TTY, -- no screen-oriented commands ANSI, -- colors supported VT100 -- no colors ); type ROW_NUMBER is new INTEGER range 1..24; type COLUMN_NUMBER is new INTEGER range 1..80; type RENDITION is (ALL_ATTRIBUTES_OFF, -- ANSI.SYS or VT100 HIGH_INTENSITY, BLINKING, REVERSE_VIDEO, FOREGROUND_BLACK, -- ANSI.SYS only FOREGROUND_RED, FOREGROUND_GREEN, FOREGROUND_YELLOW, FOREGROUND_BLUE, FOREGROUND_MAGENTA, FOREGROUND_CYAN, FOREGROUND_WHITE, BACKGROUND_BLACK, BACKGROUND_RED, BACKGROUND_GREEN, BACKGROUND_YELLOW, BACKGROUND_BLUE, BACKGROUND_MAGENTA, BACKGROUND_CYAN, BACKGROUND_WHITE); for RENDITION'Size use INTEGER'Size; for RENDITION use (ALL_ATTRIBUTES_OFF => 0, -- ANSI.SYS or VT100 HIGH_INTENSITY => 1, BLINKING => 5, REVERSE_VIDEO => 7, FOREGROUND_BLACK => 30, -- ANSI.SYS only FOREGROUND_RED => 31, FOREGROUND_GREEN => 32, FOREGROUND_YELLOW => 33, FOREGROUND_BLUE => 34, FOREGROUND_MAGENTA => 35, FOREGROUND_CYAN => 36, FOREGROUND_WHITE => 37, BACKGROUND_BLACK => 40, BACKGROUND_RED => 41, BACKGROUND_GREEN => 42, BACKGROUND_YELLOW => 43, BACKGROUND_BLUE => 44, BACKGROUND_MAGENTA => 45, BACKGROUND_CYAN => 46, BACKGROUND_WHITE => 47); type OVERFLOW_ACTION is -- used for a Put(STRING) (TRUNCATE_HEAD, -- ABC becomes "BC" TRUNCATE_TAIL, -- ABC becomes "AB" FILL_WITH_OVERFLOW_CHAR -- ABC becomes "**" ); type NUMERIC_OVERFLOW_ACTION is -- used for a Put(INTEGER) (FILL_WITH_OVERFLOW_CHAR, -- 123 becomes "**" OUTPUT_FULL_NUMBER -- 123 becomes "123" ); type JUSTIFICATION is -- used for a Put(STRING) (LEFT_JUSTIFIED, -- ABC becomes "ABC " RIGHT_JUSTIFIED -- ABC becomes " ABC" ); INPUT_ERROR : exception; -- raised on invalid input STATE_OVERFLOW : exception; -- raised if the Max_Number_of_States is exceeded STATE_UNDERFLOW : exception; -- raised if too many Pop routine calls are made -- ................................................................. -- . . -- . Console.Set_Terminal . SPEC -- . . -- ................................................................. procedure Set_Terminal (New_Setting : in TERMINAL_KIND := TTY); --| Purpose --| Define the kind of user's terminal. If this routine is not --| called, TTY is assumed. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Enable_Output . SPEC -- . . -- ................................................................. procedure Enable_Output; --| Purpose --| Enable the output routines of the console object (affects current --| state only). These routines include Position_Cursor, Erase_Display, --| Erase_Line, Set_Rendition, all the Put and Put_Line routines, and --| New_Line. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Disable_Output . SPEC -- . . -- ................................................................. procedure Disable_Output; --| Purpose --| Disable the output routines of the console object (affects current --| state only). These routines include Position_Cursor, Erase_Display, --| Erase_Line, Set_Rendition, all the Put and Put_Line routines, and --| New_Line. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Push . SPEC -- . . -- ................................................................. procedure Push; --| Purpose --| Increment to the next state (environment) of the console object. --| All states are initialized to be enabled. This routine permits, --| for example, a console to be turned off for silent running and --| then temporarily turned on for an error message display. The --| console object stays in this new state, which may be altered by --| the Enable_Output and Disable_Output routines, until a Pop is --| executed. --| --| Exceptions --| STATE_OVERFLOW -- raised if Max_Number_of_States is exceeded --| Notes (none) -- ................................................................. -- . . -- . Console.Pop . SPEC -- . . -- ................................................................. procedure Pop; --| Purpose --| Decrement to the previous state (environment) of the console object. --| All states are initialized to be enabled. See the Push routine --| for more details. --| --| Exceptions --| STATE_UNDERFLOW -- raised if current state tries to drop below 0 --| Notes (none) -- ................................................................. -- . . -- . Console.Position_Cursor . SPEC -- . . -- ................................................................. procedure Position_Cursor (Row : in ROW_NUMBER; Column : in COLUMN_NUMBER); --| Purpose --| Position the cursor to the indicated Row and Column. Row 1, --| Column 1 is the upper left corner of the screen. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Erase_Display . SPEC -- . . -- ................................................................. procedure Erase_Display; --| Purpose --| Erase the entire display and place the cursor at the home position. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Erase_Line . SPEC -- . . -- ................................................................. procedure Erase_Line; --| Purpose --| Erase from the cursor to the end of the line. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Set_Rendition . SPEC -- . . -- ................................................................. procedure Set_Rendition (New_Setting : in RENDITION); --| Purpose --| Add the indicated New_Setting to the current graphics display --| rendition (default is ALL_ATTRIBUTES_OFF). Calls to this procedure --| are cumulative until all attributes are turned off. --| --| Exceptions (none) --| --| Notes --| Color selections are ignored on a VT100 compatible terminal. -- ................................................................. -- . . -- . Console.Put . SPEC -- . . -- ................................................................. procedure Put (Item : in CHARACTER); procedure Put (Item : in STRING); --| Purpose --| Output a character or a string to the console. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Put . SPEC -- . . -- ................................................................. procedure Put ( Item : in STRING; Field_Width : in NATURAL; On_Overflow : in OVERFLOW_ACTION := TRUNCATE_TAIL; On_Underflow : in JUSTIFICATION := LEFT_JUSTIFIED; Fill_Char : in CHARACTER := ' '; Overflow_Char : in CHARACTER := '*' ); --| Purpose --| Output a string to the console in a field of a given --| Field_Width. --| If Item is shorter than Field_Width, --| the On_Underflow flag takes effect, justifying Item --| in the field as indicated using the Fill_Char. --| If Item is longer than Field_Width, the On_Overflow --| flag takes effect, either truncating Item on the left or --| right or filling the field with the Overflow_Char. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Put . SPEC -- . . -- ................................................................. procedure Put (Item : in INTEGER; Width : in NATURAL; On_Overflow : in NUMERIC_OVERFLOW_ACTION := FILL_WITH_OVERFLOW_CHAR; Overflow_Char : in CHARACTER := '*'); --| Purpose --| Output an integer to the console. It will be placed in a --| field that is Width characters long. Width of 0 fits the --| INTEGER exactly. If the resulting sequence of characters --| has fewer than Width characters, then leading spaces are --| first output to make up the difference. If the resulting --| sequence of characters has more than Width characters, --| then the On_Overflow flag takes effect. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Put . SPEC -- . . -- ................................................................. procedure Put (Item : in FLOAT; Fore : in NATURAL; Aft : in NATURAL; On_Overflow : in NUMERIC_OVERFLOW_ACTION := FILL_WITH_OVERFLOW_CHAR; Overflow_Char : in CHARACTER := '*'); --| Purpose --| Output a floating point number to the console. Fore is the --| number of characters to be displayed before the decimal point, --| and Aft is the number of characters to be displayed after the --| decimal point. Item's value appears as follows: --| --| Fore Aft fields --| ---- --- (Fore=4, Aft=3) --| nnnn.nnn if Item is positive --| -nnn.nnn if Item is negative --| ******** if overflow with defaults --| --| If Item is negative, a leading minus sign, which counts as --| one of the characters in the Fore field, is output. --| If -1.0 < Item < 1.0, then -0 or 0 is output in the Fore --| field. --| If the number of digits required to display Item in the Fore --| field exceeds the value of Fore (i.e., is too big), the --| On_Overflow flag takes effect, either overriding Fore or filling --| the field with the Overflow_Char. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Put . SPEC -- . . -- ................................................................. procedure Put (Item : in FLOAT; Fore : in NATURAL := 2; Aft : in NATURAL := 2; Exp : in NATURAL := 3); --| Purpose --| Output a floating point number in scientific notation --| to the console. Fore is the number of characters to be --| displayed before the decimal point (only one digit and --| a sign are displayed, so rest of Fore characters are --| leading spaces), Aft is the number of characters to be --| displayed after the decimal point, and Exp is the number --| of characters in the exponent. Item's value appears as: --| --| -- ---- --- (Fore=2, Aft=4, Exp=3) --| n.nnnnE+nn if Item is positive --| -n.nnnnE+nn if Item is negative --| --| The Fore field will always contain a single digit with --| an optional minus sign. If Fore > 2, leading spaces are --| prefixed to the output. Hence, Put(-123.0, 4, 2, 3) outputs --| " -1.23E+02". --| Exp is the size of the field for the number after the "E". --| This field always includes a leading sign (see -123.0 example --| above). --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Put_Line . SPEC -- . . -- ................................................................. procedure Put_Line (Item : in STRING); --| Purpose --| Output a string followed by a new line to the console. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.New_Line . SPEC -- . . -- ................................................................. procedure New_Line; --| Purpose --| Output a new line to the console. --| --| Exceptions (none) --| Notes (none) -- ................................................................. -- . . -- . Console.Get . SPEC -- . . -- ................................................................. procedure Get ( Item : out CHARACTER); procedure Get ( Item : out INTEGER); procedure Get ( Item : out FLOAT); --| Purpose --| Get views the Console input as a stream and --| returns the next Item of the appropriate type --| from it. --| --| Exceptions --| Input_Error raised if the next item --| in the stream is not of the --| correct type when translated --| from the characters or if the --| translation process encounters --| an error condition --| --| Notes --| If the Item is of type INTEGER or FLOAT, Get --| skips over whitespace characters (blank, tab, new --| line) first and then starts translating at the --| first non-white character encountered. --| If the Item is of type CHARACTER, Get returns --| the next character, whitespace or not. -- ................................................................. -- . . -- . Console.Get_Line . SPEC -- . . -- ................................................................. procedure Get_Line ( Item : out STRING; Last : out NATURAL ); --| Purpose --| Get_Line reads a line from the console. --| --| Exceptions (none) --| Notes (none) end Console; --:::::::::: --bintree.spc --:::::::::: -- ******************************************************** -- * * -- * BINARY_TREES_PKG * SPEC -- * * -- ******************************************************** generic type VALUE_TYPE is private; with function Difference(P, Q: VALUE_TYPE) return integer is <>; -- Must return a value > 0 if P > Q, 0 if P = Q, and less than -- zero otherwise. package Binary_Trees_Pkg is --| Purpose --| This package is an efficient implementation of unbalanced binary trees. --| These trees have the following properties: --| --| 1. Inserting a value is cheap (log n Differences per insertion). --| 2. Finding a value is cheap (log n Differences per querey). --| 3. Can iterate over the values in sorted order in linear time. --| 4. Space overhead is moderate (2 "pointers" per value stored). --| --| They are thus useful both for sorting sequences of indeterminate size --| and for lookup tables. --| --| Initialization Exceptions (none) --| Notes --| The following example shows how to use this package where nodes in --| the tree are labeled with a String_Type value (for which a natural --| Difference function is not available). --|- --| package SP renames String_Pkg; --| --| type my_Value is record --| label: SP.string_type; --| value: integer; --| end record; --| --| function differ_label(P, Q: SP.string_type) return integer is --| begin --| if SP."<"(P, Q) then return -1; --| elsif SP."<"(Q, P) then return 1; --| else return 0; --| end if; --| end differ_label; --| --| package my_Tree is new Binary_Trees_pkg(my_Value, differ_Label); --| --| Note that the required Difference function may be easily written in terms --| of "<" if that is available, but that frequently two comparisons must --| be done for each Difference. However, both comparisons would have --| to be done internally by this package for every instantiation if the --| generic parameter were "<" instead of Difference. --| --| PERFORMANCE --| --| Every node can be visited in the tree in linear time. The cost --| of creating an iterator is small and independent of the size --| of the tree. --| --| Recognizing that comparing values can be expensive, this package --| takes a Difference function as a generic parameter. If it took --| a comparison function such as "<", then two comparisons would be --| made per node visited during a search of the tree. Of course this --| is more costly when "<" is a trivial operation, but in those cases, --| Difference can be bound to "-" and the overhead in negligable. --| --| Two different kinds of iterators are provided. The first is the --| commonly used set of functions Make_Iter, More, and Next. The second --| is a generic procedure called Visit. The generic parameter to Visit is --| a procedure which is called once for each value in the tree. Visit --| is more difficult to use and results in code that is not quite as clear, --| but its overhead is about 20% of the More/Next style iterator. It --| is therefore recommended for use only in time critical inner loops. --| --| Modifications --| Author: Bill Toscano and Michael Gordon, Intermetrics, Inc. -- Exceptions -- Duplicate_Value: exception; -- Raised on attempt to insert a duplicate node into a tree. Not_Found: exception; -- Raised on attempt to find a node that is not in a tree. No_More: exception; -- Raised on attempt to bump an iterator that has already scanned the -- entire tree. Out_Of_Order: exception; -- Raised if a problem in the ordering of a tree is detected. Invalid_Tree: exception; -- Value is not a tree or was not properly initialized. -- Types -- type SCAN_KIND is (INORDER, PREORDER, POSTORDER); -- Used to specify the order in which values should be scanned from a tree: -- -- inorder: Left, Node, Right (nodes visited in increasing order) -- preorder: Node, Left, Right (top down) -- postorder: Left, Right, Node (bottom up) type TREE is private; type ITERATOR is private; -- Operations -- -- ..................................................... -- . . -- . BINARY_TREES_PKG.CREATE . SPEC -- . . -- ..................................................... Function Create return TREE; --| Purpose --| Create and return an empty tree. Note that this allocates --| a small amount of storage which can only be reclaimed through --| a call to Destroy. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.INSERT . SPEC -- . . -- ..................................................... Procedure Insert (V: VALUE_TYPE; T: TREE); --| Purpose --| Insert V into T in the proper place. If a value equal --| to V (according to the Difference function) is already contained --| in the tree, the exception Duplicate_Value is raised. --| Caution: Since this package does not attempt to balance trees as --| values are inserted, it is important to remember that inserting --| values in sorted order will create a degenerate tree, where search --| and insertion is proportional to the N instead of to Log N. If --| this pattern is common, use the Balanced_Tree function below. --| --| Exceptions --| Duplicate_Value --| Invalid_Tree --| --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.INSERT_IF_NOT_FOUND . SPEC -- . . -- ..................................................... procedure Insert_if_not_Found (V : VALUE_TYPE; T : TREE; Found : out BOOLEAN; Duplicate : out VALUE_TYPE); --| Purpose --| Insert V into T in the proper place. If a value equal --| to V (according to the Difference function) is already contained --| in the tree, Found will be True and Duplicate will be the duplicate --| value. This might be a sequence of values with the same key, and --| V can then be added to the sequence. --| --| Exceptions --| Invalid_Tree. --| --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.REPLACE_IF_FOUND . SPEC -- . . -- ..................................................... procedure Replace_if_Found (V : VALUE_TYPE; T : TREE; Found : out BOOLEAN; Old_Value : out VALUE_TYPE); --| Purpose --| Search for V in T. If found, replace the old value with V, --| and return Found => True, Old_Value => the old value. Otherwise, --| simply insert V into T and return Found => False. --| --| Exceptions --| Invalid_Tree. --| --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.DESTROY . SPEC -- . . -- ..................................................... procedure Destroy (T: in out TREE); --| Purpose --| The space allocated to T is reclaimed. The space occupied by --| the values stored in T is not however, recovered. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.DESTROY_DEEP . SPEC -- . . -- ..................................................... generic with procedure Free_Value(V: in out VALUE_TYPE) is <>; procedure Destroy_Deep (T: in out TREE); --| Purpose --| The space allocated to T is reclaimed. The values stored --| in T are reclaimed using Free_Value, and the tree nodes themselves --| are then reclaimed (in a single walk of the tree). --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.BALANCED_TREE . SPEC -- . . -- ..................................................... generic with function Next_Value return VALUE_TYPE is <>; -- Each call to this procedure should return the next value to be -- inserted into the balanced tree being created. If necessary, -- this function should check that each value is greater than the -- previous one, and raise Out_of_Order if necessary. If values -- are not returned in strictly increasing order, the results are -- unpredictable. Function Balanced_Tree (Count: NATURAL) return TREE; --| Purpose --| Create a balanced tree by calling next_Value Count times. --| Each time Next_Value is called, it must return a value that compares --| greater than the preceeding value. This function is useful for balancing --| an existing tree (next_Value iterates over the unbalanced tree) or --| for creating a balanced tree when reading data from a file which is --| already sorted. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.COPY_TREE . SPEC -- . . -- ..................................................... generic with function Copy_Value(V: VALUE_TYPE) return VALUE_TYPE is <>; -- This function is called to copy a value from the old tree to the -- new tree. Function Copy_Tree (T: TREE) return TREE; --| Purpose --| Create a balanced tree that is a copy of the tree T. --| The exception Invalid_Tree is raised if T is not a valid tree. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.IS_EMPTY . SPEC -- . . -- ..................................................... Function Is_Empty (T: TREE) return BOOLEAN; --| Purpose --| Return TRUE iff T is an empty tree or if T was not initialized. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.FIND . SPEC -- . . -- ..................................................... Function Find (V: VALUE_TYPE; T: TREE) return VALUE_TYPE; --| Purpose --| Search T for a value that matches V. The matching value is --| returned. If no matching value is found, the exception Not_Found --| is raised. --| --| Exceptions --| Not_Found --| Invalid_Tree --| --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.FIND . SPEC -- . . -- ..................................................... Procedure Find (V : VALUE_TYPE; T : TREE; Found : out BOOLEAN; Match : out VALUE_TYPE); --| Purpose --| Search T for a value that matches V. On return, if Found is --| TRUE then the matching value is returned in Match. Otherwise, Found --| is FALSE and Match is undefined. --| --| Exceptions --| Invalid_Tree; --| --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.IS_FOUND . SPEC -- . . -- ..................................................... function Is_Found (V: VALUE_TYPE; T: TREE) return BOOLEAN; --| Purpose --| Return TRUE iff V is found in T. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.SIZE . SPEC -- . . -- ..................................................... function Size (T: TREE) return NATURAL; --| Purpose --| Return the number of values stored in T. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.VISIT . SPEC -- . . -- ..................................................... generic with procedure Process(V: VALUE_TYPE) is <>; procedure Visit (T : TREE; Order : SCAN_KIND); --| Purpose --| Invoke Process(V) for each value V in T. The nodes are visited --| in the order specified by Order. Although more limited than using --| an iterator, this function is also much faster. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.MAKE_ITER . SPEC -- . . -- ..................................................... function Make_Iter (T: TREE) return ITERATOR; --| Purpose --| Create an iterator over a tree. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.MORE . SPEC -- . . -- ..................................................... function More (I: ITERATOR) return BOOLEAN; --| Purpose --| Return TRUE iff unscanned nodes remain in the tree being --| scanned by I. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . BINARY_TREES_PKG.NEXT . SPEC -- . . -- ..................................................... procedure Next (I: in out ITERATOR; V: out VALUE_TYPE); --| Purpose --| Return the next value in the tree being scanned by I. --| The exception No_More is raised if there are no more values to scan. --| --| Exceptions --| No_More --| --| Notes (none) private type NODE; type NODE_PTR is access NODE; type NODE is record Value : VALUE_TYPE; Less : NODE_PTR; More : NODE_PTR; end record; type TREE_HEADER is record Count : NATURAL := 0; Root : NODE_PTR := Null; end record; type TREE is access TREE_HEADER; type ITER_STATE is (LEFT, MIDDLE, RIGHT, DONE); type ITERATOR_RECORD; type ITERATOR is access ITERATOR_RECORD; type ITERATOR_RECORD is record State : ITER_STATE; Parent : ITERATOR; Subtree : NODE_PTR; end record; end Binary_Trees_Pkg; --:::::::::: --bit.spc --:::::::::: -- *************************************************************** -- * * -- * BIT_FUNCTIONS * SPEC -- * * -- *************************************************************** package Bit_Functions is --| Purpose --| This package allows the Ada programmer to manipulate the bits --| within an object of type INTEGER. The bits are numbers from --| the right to the left, starting with number zero. --| --| +------------------------+ --| + 15 14 13 ... 3 2 1 0 ! --| +------------------------+ --| --| In each routine, the number of bits being manipulated --| is NBITS. START_AT identifies the right most bit of NBITS field. --| --| e.g. --| ... 6 5 4 3 2 1 0 --| X X X nbits = 3 --| start_at = 2 --| --| Initialization Exceptions (none) --| Notes --| Not all MIL-HDBK-1804 PDL annotations are --| used in this package due to its simplicity. --| No exceptions are raised by this package. --| --| Modifications --| Author: Freeman Moore, TI -- .................................................................. -- . . -- . BIT_FUNCTIONS.BIT_EXTRACT . SPEC -- . . -- .................................................................. function Bit_Extract (Item, Start_At, Nbits : INTEGER) return INTEGER; --| Purpose --| Return the bit field extracted from ITEM, as a signed integer. -- .................................................................. -- . . -- . BIT_FUNCTIONS.UBIT_EXTRACT . SPEC -- . . -- .................................................................. function Ubit_Extract (Item, Start_At, Nbits : INTEGER) return INTEGER; --| Purpose --| Return the bit field extracted from ITEM, unsigned integer. -- .................................................................. -- . . -- . BIT_FUNCTIONS.BIT_INSERT . SPEC -- . . -- .................................................................. function Bit_Insert (This_Item, Nbits, Into_Item, Start_At : INTEGER) return INTEGER; --| Purpose --| Insert NBITS from THIS_ITEM into the object INTO_ITEM, --| with the rightmost bit identified by START_AT. -- .................................................................. -- . . -- . BIT_FUNCTIONS.BIT_REMOVE . SPEC -- . . -- .................................................................. function Bit_Remove (Item, Start_At, Nbits : INTEGER) return INTEGER; --| Purpose --| BIT_REMOVE will zero out NBITS of ITEM at position START_AT. -- .................................................................. -- . . -- . BIT_FUNCTIONS.SHIFT_LEFT . SPEC -- . . -- .................................................................. function Shift_Left (Item, Nbits : INTEGER) return INTEGER; --| Purpose --| Return ITEM shifted left by NBITS. -- .................................................................. -- . . -- . BIT_FUNCTIONS.SHIFT_RIGHT . SPEC -- . . -- .................................................................. function Shift_Right (Item, Nbits : INTEGER) return INTEGER; --| Purpose --| Return ITEM shifted right by NBITS. -- .................................................................. -- . . -- . BIT_FUNCTIONS.BIT_AND . SPEC -- . . -- .................................................................. function Bit_AND (Word1, Word2 : INTEGER) return INTEGER; --| Purpose --| Return the AND of the two objects. -- .................................................................. -- . . -- . BIT_FUNCTIONS.BIT_OR . SPEC -- . . -- .................................................................. function Bit_OR (Word1, Word2 : INTEGER) return INTEGER; --| Purpose --| Return the OR of the two objects. -- .................................................................. -- . . -- . BIT_FUNCTIONS.BIT_MASK . SPEC -- . . -- .................................................................. function Bit_Mask (Nbits : INTEGER) return INTEGER; --| Purpose --| Return an object with NBITS of one bits, right justified. end Bit_Functions; --:::::::::: --bplustre.spc --:::::::::: -- ********************************************************** -- * * -- * BP_Tree * SPEC -- * * -- ********************************************************** generic type KEY_TYPE is limited private; type NON_KEY_ITEM_TYPE is limited private; type NON_KEY_ITEM_CONTAINER is limited private; with function Empty (This_Non_Key_Item_Container : in NON_KEY_ITEM_CONTAINER) return Boolean is <>; with procedure Assign (To_Non_Key_Item_Container : in out NON_KEY_ITEM_CONTAINER; From_Non_Key_Item_Container : in NON_KEY_ITEM_CONTAINER) is <>; with procedure Insert (Container : in out NON_KEY_ITEM_CONTAINER; Non_Key_Item : in NON_KEY_ITEM_TYPE ) is <>; with procedure Delete (Container : in out NON_KEY_ITEM_CONTAINER; Non_Key_Item : in NON_KEY_ITEM_TYPE ) is <>; with procedure Destroy_Contents (This_Non_Key_Item_Container : in out NON_KEY_ITEM_CONTAINER) is <>; -- This procedure must destroy everything in the container -- in preparation for the destruction of the container itself. with procedure Assign (Target_Key : in out KEY_TYPE; Source_Key : in KEY_TYPE) is <>; with function Less_Than (First_Key : in KEY_TYPE; Second_Key : in KEY_TYPE) return Boolean is <>; with function Equal (First_Key : in KEY_TYPE; Second_Key : in KEY_TYPE) return Boolean is <>; package BP_Tree is --| Purpose --| Implement a B+ Tree class of objects. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: William Thomas Wolfe, Clemson University -- ******************************************************* -- This software is part of the Clemson University -- Computer Science Department's Ada Software -- Repository, and is copyrighted (C) 1989 by -- Clemson University. Permission to copy without -- fee all or part of this software is granted, -- provided that the copies are not made or -- distributed for direct commercial advantage, and -- that this copyright notice is not deleted or -- modified. To copy otherwise, or to republish, -- requires a fee and/or specific permission. -- ******************************************************* type B_PLUS_TREE is limited private; Key_Does_Not_Exist_In_This_B_Plus_Tree : EXCEPTION; No_Preceding_Key_Exists_In_This_B_Plus_Tree : EXCEPTION; No_Following_Key_Exists_In_This_B_Plus_Tree : EXCEPTION; No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree : EXCEPTION; type POINTER_TO_B_PLUS_TREE is access B_PLUS_TREE; -- .................................................... -- . . -- . BP_Tree.Destroy . SPEC -- . . -- .................................................... procedure Destroy (Targeted_Object : in out POINTER_TO_B_PLUS_TREE); --| Purpose --| Unlike Unchecked_Deallocation, this procedure will properly --| destroy the B_Plus_Tree pointed to. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Insert_Item . SPEC -- . . -- .................................................... procedure Insert_Item (Targeted_B_Plus_Tree : in out B_PLUS_TREE; Key_Value : in KEY_TYPE; Non_Key_Information : in NON_KEY_ITEM_TYPE); --| Purpose --| Insert an element into the Targeted_B_Plus_Tree. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Delete_Item . SPEC -- . . -- .................................................... procedure Delete_Item (Targeted_B_Plus_Tree : in out B_PLUS_TREE; Key_Value : in KEY_TYPE; Non_Key_Information : in NON_KEY_ITEM_TYPE); --| Purpose --| Remove an element from the Targeted_B_Plus_Tree. --| --| Exceptions --| Key_Does_Not_Exist_In_This_B_Plus_Tree --| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree --| --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Key_Exists . SPEC -- . . -- .................................................... function Key_Exists (Targeted_B_Plus_Tree : in B_PLUS_TREE; Search_Key : in KEY_TYPE) return BOOLEAN; --| Purpose --| Return TRUE iff Search_Key is found in Targeted_B_Plus_Tree. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Number_Of_Keys_Stored . SPEC -- . . -- .................................................... function Number_Of_Keys_Stored (Targeted_B_Plus_Tree : in B_PLUS_TREE) return NATURAL; --| Purpose --| Return the Number_of_Keys_Stored in Targeted_B_Plus_Tree. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Get_Item_Container . SPEC -- . . -- .................................................... function Get_Item_Container (Targeted_B_Plus_Tree : in B_PLUS_TREE; Search_Key : in KEY_TYPE ) return NON_KEY_ITEM_CONTAINER; --| Purpose --| Return the NON_KEY_ITEM_CONTAINER associated with the --| Search_Key in Targeted_B_Plus_Tree. --| --| Exceptions --| Key_Does_Not_Exist_In_This_B_Plus_Tree --| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree --| --| Notes --| This procedure involves copying the entire container. If --| your NON_KEY_ITEM_TYPE is quite large, it may be advisable --| to implement it as a pointer to the "real" structures, --| thus reducing the copying burden per instance of the --| NON_KEY_ITEM_TYPE to that of a single pointer. -- .................................................... -- . . -- . BP_Tree.Get_First_Key . SPEC -- . . -- .................................................... function Get_First_Key (Targeted_B_Plus_Tree : in B_PLUS_TREE) return KEY_TYPE; --| Purpose --| Return the first KEY_TYPE in Targeted_B_Plus_Tree. --| --| Exceptions --| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree --| --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Get_Last_Key . SPEC -- . . -- .................................................... function Get_Last_Key (Targeted_B_Plus_Tree : in B_PLUS_TREE) return KEY_TYPE; --| Purpose --| Return the last KEY_TYPE in Targeted_B_Plus_Tree. --| --| Exceptions --| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree --| --| Notes (none) -- .................................................... -- . . -- . BP_Tree.A_Preceding_Key_Exists . SPEC -- . . -- .................................................... function A_Preceding_Key_Exists (Targeted_B_Plus_Tree : in B_PLUS_TREE; Search_Key : in KEY_TYPE) return Boolean; --| Purpose --| Determine if a key exists in the Targeted_B_Plus_Tree --| before the Search_Key. --| --| Exceptions --| Key_Does_Not_Exist_In_This_B_Plus_Tree --| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree --| --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Get_Preceding_Key . SPEC -- . . -- .................................................... function Get_Preceding_Key (Targeted_B_Plus_Tree : in B_PLUS_TREE; Search_Key : in KEY_TYPE) return KEY_TYPE; --| Purpose --| Obtain the preceding key in the Targeted_B_Plus_Tree --| before the Search_Key. --| --| Exceptions --| Key_Does_Not_Exist_In_This_B_Plus_Tree --| No_Preceding_Key_Exists_In_This_B_Plus_Tree --| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree --| --| Notes (none) -- .................................................... -- . . -- . BP_Tree.A_Following_Key_Exists . SPEC -- . . -- .................................................... function A_Following_Key_Exists (Targeted_B_Plus_Tree : in B_PLUS_TREE; Search_Key : in KEY_TYPE) return Boolean; --| Purpose --| Determine if a key exists in the Targeted_B_Plus_Tree after --| the Search_Key. --| --| Exceptions --| Key_Does_Not_Exist_In_This_B_Plus_Tree --| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree --| --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Get_Following_Key . SPEC -- . . -- .................................................... function Get_Following_Key (Targeted_B_Plus_Tree : in B_PLUS_TREE; Search_Key : in KEY_TYPE) return KEY_TYPE; --| Purpose --| Obtain the following key in the Targeted_B_Plus_Tree --| before the Search_Key. --| --| Exceptions --| Key_Does_Not_Exist_In_This_B_Plus_Tree --| No_Following_Key_Exists_In_This_B_Plus_Tree --| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree --| --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Delete_Key . SPEC -- . . -- .................................................... procedure Delete_Key (Targeted_B_Plus_Tree : in out B_PLUS_TREE; Search_Key : in KEY_TYPE); --| Purpose --| Remove a Search_Key from the Targeted_B_Plus_Tree. --| --| Exceptions --| Key_Does_Not_Exist_In_This_B_Plus_Tree --| No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree --| --| Notes --| The NON_KEY_ITEM_CONTAINER associated with this key will --| be emptied via the Destroy_Contents procedure. -- .................................................... -- . . -- . BP_Tree.Exchange . SPEC -- . . -- .................................................... procedure Exchange (First_B_Plus_Tree : in out B_PLUS_TREE; Second_B_Plus_Tree : in out B_PLUS_TREE); --| Purpose --| Exchanges the values of First_B_PLUS_TREE and --| Second_B_PLUS_TREE in O(1) time. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Assign . SPEC -- . . -- .................................................... procedure Assign (To_B_Plus_Tree : in out B_PLUS_TREE; From_B_Plus_Tree : in B_PLUS_TREE); --| Purpose --| Replaces the contents of To_B_Plus_Tree with --| From_B_Plus_Tree. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Destroy . SPEC -- . . -- .................................................... procedure Destroy (Targeted_B_Plus_Tree : in out B_PLUS_TREE); --| Purpose --| Destroys all keys and all associated containers --| and renders the tree Empty. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . BP_Tree.Destroy . SPEC -- . . -- .................................................... function Empty (Targeted_B_Plus_Tree: in B_PLUS_TREE) return Boolean; --| Purpose --| Determine if Targeted_B_Plus_Tree is empty. --| --| Exceptions (none) --| Notes (none) private type B_PLUS_TREE_DESCRIPTOR; type B_PLUS_TREE is access B_PLUS_TREE_DESCRIPTOR; end BP_Tree; --:::::::::: --cisc.spc --:::::::::: -- ******************************************* -- * * -- * CASE_INSENSITIVE_STRING_COMPARISON * SPEC -- * * -- ******************************************* package Case_Insensitive_String_Comparison is --| Purpose --| This package provides a complete set of comparison functions on strings --| where case is NOT important ("a" = "A"). --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Programmer: Michael Gordon -- ................................................. -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.TOUPPER . SPEC -- . . -- ................................................. function ToUpper (C: CHARACTER) return CHARACTER; --| Purpose --| If C is in 'a'..'z' return the corresponding upper case --| character. Otherwise, return C. This is implemented by a table --| lookup for speed. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.UPCASE . SPEC -- . . -- ................................................. procedure UpCase (S: in out STRING); --| Purpose --| Convert all characters in S to upper case. --| --| Exceptions (none) --| Notes (none) pragma inline(UpCase); -- ................................................. -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.UPCASE . SPEC -- . . -- ................................................. function UpCase (S: STRING) return STRING; --| Purpose --| Make a copy of S, convert all lower case characters to upper --| case and return the copy. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.TOLOWER . SPEC -- . . -- ................................................. function ToLower (C: CHARACTER) return CHARACTER; --| Purpose --| If C is in 'A'..'Z' return the corresponding lower case --| character. Otherwise, return C. This is implemented by a table --| lookup for speed. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.DOWNCASE . SPEC -- . . -- ................................................. procedure DownCase (S: in out STRING); --| Purpose --| Convert all characters in S to lower case. --| --| Exceptions (none) --| Notes (none) pragma inline(DownCase); -- ................................................. -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.DOWNCASE . SPEC -- . . -- ................................................. function DownCase (S: STRING) return STRING; --| Purpose --| Make a copy of S, convert all lower case characters to lower --| case and return the copy. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.COMPARE . SPEC -- . . -- ................................................. function Compare (P, Q: STRING) return INTEGER; --| Purpose --| Return an integer less than zero if P < Q, zero if P = Q, and --| an integer greater than zero if P > Q. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.EQUAL . SPEC -- . . -- ................................................. function Equal (P, Q: STRING) return BOOLEAN; --| Purpose --| Return TRUE iff P = Q. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.LESS . SPEC -- . . -- ................................................. function Less (P, Q: STRING) return BOOLEAN; --| Purpose --| Return TRUE iff P < Q. --| --| Exceptions (none) --| Notes (none) -- ...................................................... -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.LESS_OR_EQUAL . SPEC -- . . -- ...................................................... function Less_or_Equal (P, Q: STRING) return BOOLEAN; --| Purpose --| Return TRUE iff P <= Q. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.GREATER . SPEC -- . . -- ................................................. function Greater (P, Q: STRING) return BOOLEAN; --| Purpose --| Return TRUE iff P > Q. --| --| Exceptions (none) --| Notes (none) -- .......................................................... -- . . -- . CASE_INSENSITIVE_STRING_COMPARISION.GREATER_OR_EQUAL . SPEC -- . . -- .......................................................... function Greater_or_Equal (P, Q: STRING) return BOOLEAN; --| Purpose --| Return TRUE iff P >= Q. --| --| Exceptions (none) --| Notes (none) private pragma inline (Equal, Less, Less_or_Equal, Greater, Greater_or_Equal); pragma inline (ToUpper, ToLower); end Case_Insensitive_String_Comparison; --:::::::::: --cli.spc --:::::::::: -- ************************************** -- * * -- * CLI (Command Line Interface) * SPEC -- * * -- ************************************** package CLI is --| Purpose --| CLI is a package which implements a Command --| Line Interface. It mirrors the UNIX/C --| command line interface, providing an argument --| count and the arguments themselves. --| --| Initialization Exceptions (none) --| --| Notes --| Compiler limit on string length and dynamic memory. --| INITIALIZE must be called once, and only once, during --| the execution of the main Ada proc. --| --| Modifications --| 2/25/88 Richard Conn Initial Version --| 5/12/89 Richard Conn Review and Upgrade --| 4/11/90 Richard Conn MIL-HDBK-1804 Annotations and --| Meridian Ada Interface Added -- ................................... -- . . -- . CLI.INITIALIZE . SPEC -- . . -- ................................... procedure Initialize (Program_Name : in STRING; Command_Line_Prompt : in STRING); --| Purpose --| Initialize this package. This routine must be called --| before any other routines or objects are called or referenced. --| --| Exceptions (none) --| --| Notes --| CALL THIS PROCEDURE ONLY ONE TIME -- ................................... -- . . -- . CLI.ARGC (Argument Count) . SPEC -- . . -- ................................... function ArgC return NATURAL; --| Purpose --| Return the number (1 to N) of command line arguments. --| ARGC is at least 1 because the name of the program or --| process is always ARGV(0). --| --| Exceptions (none) --| Notes (none) -- ................................... -- . . -- . CLI.ARGV (Argument Value) . SPEC -- . . -- ................................... function ArgV (Index : in NATURAL) return STRING; --| Purpose --| Return the INDEXth (0 <= INDEX < ARGC) command line --| argument. Example: if ARGC = 1, ARGV(0) is the only --| valid argument string. ARGV(0) is always the name of --| the program or process. --| --| Exceptions --| INVALID_INDEX raised if Index >= ARGC --| --| Notes (none) INVALID_INDEX : exception; UNEXPECTED_ERROR : exception; -- raised anytime end CLI; --:::::::::: --cset.spc --:::::::::: -- ****************************************************** -- * * -- * Character_Set * SPEC -- * * -- ****************************************************** package Character_Set is --| Purpose --| These routines test for the following subsets of package --| ASCII: --| Routine Subset tested for --| ======= ================= --| ALPHA 'a'..'z' | 'A'..'Z' --| ALPHA_NUMERIC ALPHA | '0'..'9' --| CONTROL < ' ' | DEL --| DIGIT '0'..'9' --| GRAPHIC ' ' < ch < DEL (does not include space) --| HEXADECIMAL DIGIT | 'A'..'F' | 'a'..'f' --| LOWER 'a'..'z' --| PRINTABLE GRAPHIC | ' ' --| PUNCTUATION GRAPHIC and not ALPHA_NUMERIC --| SPACE HT | LF | VT | FF | CR | ' ' --| UPPER 'A'..'Z' --| --| Initialization Exceptions (none) --| Notes --| Most of the "functions" are actually arrays indexed by --| CHARACTER, so they are remarkably efficient. --| Not all MIL-HDBK-1804 PDL annotations are --| used in this package due to its simplicity. --| --| Modifications --| Author: Richard Conn, TI --| Modified by: Joseph M. Orost, Concurrent Computer Corp use ASCII; type BIT_ARRAY is array (CHARACTER) of BOOLEAN; pragma PACK (BIT_ARRAY); -- ................................................... -- . . -- . Character_Set.Is_Alpha . SPEC -- . . -- ................................................... Is_Alpha : constant BIT_ARRAY := BIT_ARRAY'('a' .. 'z' => TRUE, 'A' .. 'Z' => TRUE, others => FALSE); -- ................................................... -- . . -- . Character_Set.Is_Alpha_Numeric . SPEC -- . . -- ................................................... Is_Alpha_Numeric : constant BIT_ARRAY := BIT_ARRAY'('a' .. 'z' => TRUE, 'A' .. 'Z' => TRUE, '0' .. '9' => TRUE, others => FALSE ); -- ................................................... -- . . -- . Character_Set.Is_Control . SPEC -- . . -- ................................................... Is_Control : constant BIT_ARRAY := BIT_ARRAY'(NUL .. US => TRUE, DEL => TRUE, others => FALSE); -- ................................................... -- . . -- . Character_Set.Is_Digit . SPEC -- . . -- ................................................... Is_Digit : constant BIT_ARRAY := BIT_ARRAY'('0' .. '9' => TRUE, others => FALSE); -- ................................................... -- . . -- . Character_Set.Is_Graphic . SPEC -- . . -- ................................................... Is_Graphic : constant BIT_ARRAY := BIT_ARRAY'('!' .. '~' => TRUE, others => FALSE); -- ................................................... -- . . -- . Character_Set.Is_Hexadecimal . SPEC -- . . -- ................................................... Is_Hexadecimal : constant BIT_ARRAY := BIT_ARRAY'('0' .. '9' => TRUE, 'A' .. 'F' => TRUE, 'a' .. 'f' => TRUE, others => FALSE ); -- ................................................... -- . . -- . Character_Set.Is_Lower . SPEC -- . . -- ................................................... Is_Lower : constant BIT_ARRAY := BIT_ARRAY'('a' .. 'z' => TRUE, others => FALSE); -- ................................................... -- . . -- . Character_Set.Is_Printable . SPEC -- . . -- ................................................... Is_Printable : constant BIT_ARRAY := BIT_ARRAY'(' ' .. '~' => TRUE, others => FALSE); -- ................................................... -- . . -- . Character_Set.Is_Punctuation . SPEC -- . . -- ................................................... Is_Punctuation : constant BIT_ARRAY := BIT_ARRAY'('!' .. '/' => TRUE, ':' .. '@' => TRUE, '[' .. '`' => TRUE, '{' .. '~' => TRUE, others => FALSE ); -- ................................................... -- . . -- . Character_Set.Is_Space . SPEC -- . . -- ................................................... Is_Space : constant BIT_ARRAY := BIT_ARRAY'(HT => TRUE, LF => TRUE, VT => TRUE, FF => TRUE, CR => TRUE, ' ' => TRUE, others => FALSE); -- ................................................... -- . . -- . Character_Set.Is_Upper . SPEC -- . . -- ................................................... Is_Upper : constant BIT_ARRAY := BIT_ARRAY'('A' .. 'Z' => TRUE, others => FALSE); type TRANSLATION_ARRAY is array (CHARACTER) of CHARACTER; pragma PACK (TRANSLATION_ARRAY); -- ................................................... -- . . -- . Character_Set.Lower . SPEC -- . . -- ................................................... Lower : constant TRANSLATION_ARRAY := --| Notes --| LOWER can be used in place of TO_LOWER (Ada won't --| allow overloading of an object and a procedure). (NUL, SOH, STX, ETX, EOT, ENQ, ACK, BEL, BS , HT , LF , VT , FF , CR , SO , SI , DLE, DC1, DC2, DC3, DC4, NAK, SYN, ETB, CAN, EM , SUB, ESC, FS , GS , RS , US , ' ', '!', '"', ASCII.SHARP, '$', '%', '&', ''', '(', ')', '*', '+', ',', '-', '.', '/', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', ':', ';', '<', '=', '>', '?', '@', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '[', '\', ']', '^', '_', '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '{', '|', '}', '~', DEL); -- ................................................... -- . . -- . Character_Set.To_Lower . SPEC -- . . -- ................................................... function To_Lower (Ch : in CHARACTER) return CHARACTER; procedure To_Lower (Ch : in out CHARACTER); procedure To_Lower (Str : in out STRING); -- ................................................... -- . . -- . Character_Set.Upper . SPEC -- . . -- ................................................... Upper : constant TRANSLATION_ARRAY := --| Notes --| UPPER can be used in place of TO_UPPER. --| (NUL, SOH, STX, ETX, EOT, ENQ, ACK, BEL, BS , HT , LF , VT , FF , CR , SO , SI , DLE, DC1, DC2, DC3, DC4, NAK, SYN, ETB, CAN, EM , SUB, ESC, FS , GS , RS , US , ' ', '!', '"', ASCII.SHARP, '$', '%', '&', ''', '(', ')', '*', '+', ',', '-', '.', '/', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', ':', ';', '<', '=', '>', '?', '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', ']', '^', '_', '`', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '{', '|', '}', '~', DEL); -- ................................................... -- . . -- . Character_Set.To_Upper . SPEC -- . . -- ................................................... function To_Upper (Ch : in CHARACTER) return CHARACTER; procedure To_Upper (Ch : in out CHARACTER); procedure To_Upper (Str : in out STRING); subtype CONTROL_CHARACTER_NAME_2 is STRING (1 .. 2); subtype CONTROL_CHARACTER_NAME_3 is STRING (1 .. 3); -- ................................................... -- . . -- . Character_Set.CC_Name_2 . SPEC -- . . -- ................................................... function CC_Name_2 (Ch : CHARACTER) return CONTROL_CHARACTER_NAME_2; --| Purpose --| Returns Ch as a two-character string. If Ch is a control --| character, the string contains a caret (^) followed by --| the control character letter (e.g., ^H for ASCII.BS). --| If Ch is not a control character, the string contains a --| leading space and the character. -- ................................................... -- . . -- . Character_Set.CC_Name_3 . SPEC -- . . -- ................................................... function CC_Name_3 (Ch : CHARACTER) return CONTROL_CHARACTER_NAME_3; --| Purpose --| Returns Ch as a three-character string. If Ch is a control --| character, the string contains the name given in ASCII (e.g., --| "BS " for ^H). If Ch is not a control character, the string --| contains two leading spaces and the character. end Character_Set; --:::::::::: --cssc.spc --:::::::::: -- ******************************************************** -- * * -- * Case_Sensitive_String_Comparison * SPEC -- * * -- ******************************************************** package Case_Sensitive_String_Comparison is --| Purpose --| This package provides a complete set of comparison --| functions on strings where case is important ("a" /= "A"). --| In most cases these have the same effect as the Ada --| predefined operators. However, using this package --| makes it easier to substitute case-insensitive comparison --| later. --| --| Initialization Exceptions (none) --| Notes --| No exceptions are raised by any method, so the MIL-HDBK-1804 --| annotation requirements are reduced. --| --| Modifications --| Author: Michael Gordon, Intermetrics -- ................................................... -- . . -- . Case_Sensitive_String_Comparison.Compare . SPEC -- . . -- ................................................... function Compare (P, Q: STRING) return INTEGER; --| Purpose --| Return an integer less than zero if P < Q, zero if --| P = Q, and an integer greater than zero if P > Q. -- ................................................... -- . . -- . Case_Sensitive_String_Comparison.Equal . SPEC -- . . -- ................................................... function Equal (P, Q: STRING) return BOOLEAN; --| Purpose --| Return True iff P = Q. -- ................................................... -- . . -- . Case_Sensitive_String_Comparison.Less . SPEC -- . . -- ................................................... function Less (P, Q: STRING) return BOOLEAN; --| Purpose --| Return True iff P < Q. -- ................................................... -- . . -- . Case_Sensitive_String_Comparison.Less_or_Equal . SPEC -- . . -- ................................................... function Less_or_Equal (P, Q: STRING) return BOOLEAN; --| Purpose --| Return True iff P <= Q. -- ................................................... -- . . -- . Case_Sensitive_String_Comparison.Greater . SPEC -- . . -- ................................................... function Greater (P, Q: STRING) return BOOLEAN; --| Purpose --| Return True iff P > Q. -- ...................................................... -- . . -- . Case_Sensitive_String_Comparison.Greater_or_Equal . SPEC -- . . -- ...................................................... function Greater_or_Equal (P, Q: STRING) return BOOLEAN; --| Purpose --| Return True iff P >= Q. private pragma Inline (equal, less, less_or_equal, greater, greater_or_equal); end Case_Sensitive_String_Comparison; --:::::::::: --cstrings.spc --:::::::::: -- ********************************************************* -- * * -- * CStrings * SPEC -- * * -- ********************************************************* generic Max_String_Length : NATURAL := 400; -- max length of a string -- including the trailing -- ASCII.NUL character package CStrings is --| Purpose --| CStrings provides a number of procedures and functions --| which manipulate null-terminated strings (called C Strings) --| and Ada strings (which contain no null character). --| Type STRING is used to contain the C and Ada strings. --| A C string contains a sequence of characters followed --| by an ASCII.NUL; more characters may follow the ASCII.NUL --| in the buffer, but they are ignored. An Ada string is --| a sequence of characters bound by the dimensions of the --| buffer; all characters in the buffer are a part of the --| string. --| The names of these procedures and functions were taken --| from a listing of string-oriented C library functions. --| The functionality of these routines is almost always --| identical to the functionality of the original C routines. --| --| Initialization Exceptions (none) --| Notes --| Reference Sun Release 4.0 man pages on "strings". --| Each string referenced in this specification is followed --| by one of the following comments: --| --| Comment Meaning --| =========== ========================================= --| -- Ada The string is an Ada String --| -- C The string is a C String --| -- Ada or C The string is an Ada String or a C String --| --| Modifications Author: Richard Conn, MACA --| 2/27/90 Richard Conn Initial Version and Release type COMPARISON_RESULT is (LESS_THAN, EQUAL_TO, GREATER_THAN); -- Exceptions LENGTH_ERROR : exception; -- resulting string length -- is too long for buffer -- ................................................... -- . . -- . CStrings.Make_Cstring . SPEC -- . . -- ................................................... procedure Make_Cstring (From : in STRING; -- Ada or C To : out STRING); -- C --| Purpose --| Place a copy of From into To. Place --| the null terminator (ASCII.NUL) at the character --| in To corresponding to From(From'LAST+1). --| --| Exceptions --| LENGTH_ERROR -- Destination is too short to hold --| the result or the result exceeds --| Max_String_Length characters -- ................................................... -- . . -- . CStrings.Make_Cstring . SPEC -- . . -- ................................................... procedure Make_Cstring (From_To : in out STRING; -- Ada or C Index : in NATURAL); --| Purpose --| Place a null into From_To on the indicated --| character. --| --| Exceptions --| LENGTH_ERROR -- Index is out of bounds -- ................................................... -- . . -- . CStrings.Ada_String . SPEC -- . . -- ................................................... function Ada_String (From : in STRING) -- Ada or C return STRING; -- Ada --| Purpose --| Return the slice of From up to but not including --| the ending NUL. If From is an Ada string (no null), --| then the entire string is returned. --| --| Exceptions (none) -- ................................................... -- . . -- . CStrings.Strcat . SPEC -- . . -- ................................................... procedure Strcat (To : in out STRING; -- C From : in STRING); -- Ada or C function Strcat (From_Part_1 : in STRING; -- Ada or C From_Part_2 : in STRING) -- Ada or C return STRING; -- C --| Purpose --| Strcat appends a copy of string Source to the end --| of string Destination. The procedure Strcat modifies --| the string Destination, while the function Strcat --| does not modify the string Destination. --| --| Exceptions --| LENGTH_ERROR -- Destination is too short to hold --| the result or the result exceeds --| Max_String_Length characters -- ................................................... -- . . -- . CStrings.Strncat . SPEC -- . . -- ................................................... procedure Strncat (To : in out STRING; -- C From : in STRING; -- Ada or C Length : in NATURAL); function Strncat (To : in STRING; -- Ada or C From : in STRING; -- Ada or C Length : in NATURAL) return STRING; -- C --| Purpose --| Strncat appends a copy of string From to the end --| of string To. The procedure Strncat modifies --| the string To, while the function Strncat --| does not modify the string To. At most Length --| characters are appended. --| --| Exceptions --| LENGTH_ERROR -- Destination is too short to hold --| the result or the result exceeds --| Max_String_Length characters -- ................................................... -- . . -- . CStrings.Strcmp . SPEC -- . . -- ................................................... function Strcmp (String1 : in STRING; -- Ada or C String2 : in STRING) -- Ada or C return COMPARISON_RESULT; --| Purpose --| Strcmp compares its arguments and returns the values --| LESS_THAN, EQUAL_TO, or GREATER_THAN accordingly as --| String1 is lexicographically less than, equal to, or --| greater than String2. --| --| Exceptions (none) -- ................................................... -- . . -- . CStrings.Strncmp . SPEC -- . . -- ................................................... function Strncmp (String1 : in STRING; -- Ada or C String2 : in STRING; -- Ada or C Length : in NATURAL) return COMPARISON_RESULT; --| Purpose --| Strncmp compares its arguments and returns the values --| LESS_THAN, EQUAL_TO, or GREATER_THAN accordingly as --| String1 is lexicographically less than, equal to, or --| greater than String2. Strncmp compares at most --| Length characters. --| --| Exceptions (none) -- ................................................... -- . . -- . CStrings.Strcasecmp . SPEC -- . . -- ................................................... function Strcasecmp (String1 : in STRING; -- Ada or C String2 : in STRING) -- Ada or C return COMPARISON_RESULT; --| Purpose --| Strcasecmp compares its arguments and returns the values --| LESS_THAN, EQUAL_TO, or GREATER_THAN accordingly as --| String1 is lexicographically less than, equal to, or --| greater than String2. Differences in case are ignored. --| --| Exceptions (none) -- ................................................... -- . . -- . CStrings.Strncasecmp . SPEC -- . . -- ................................................... function Strncasecmp (String1 : in STRING; -- Ada or C String2 : in STRING; -- Ada or C Length : in NATURAL) return COMPARISON_RESULT; --| Purpose --| Strncasecmp compares its arguments and returns the values --| LESS_THAN, EQUAL_TO, or GREATER_THAN accordingly as --| String1 is lexicographically less than, equal to, or --| greater than String2. Differences in case are ignored. --| At most Length characters are compared. --| --| Exceptions (none) -- ................................................... -- . . -- . CStrings.Strcpy . SPEC -- . . -- ................................................... procedure Strcpy (From : in STRING; -- Ada or C To : out STRING); -- C --| Purpose --| Strcpy copies From to To, stopping after --| the null character has been copied. --| --| Exceptions --| LENGTH_ERROR -- Destination is too short to hold --| the result -- ................................................... -- . . -- . CStrings.Strncpy . SPEC -- . . -- ................................................... procedure Strncpy (From : in STRING; -- Ada or C To : out STRING; -- C Length : in NATURAL); --| Purpose --| Strncpy copies From to To, copying --| at most Length characters. If there are more --| than Length characters in To, Length --| characters will be copied and a trailing null --| appended after the last character. --| --| Exceptions --| LENGTH_ERROR -- Destination is too short to hold --| the result -- ................................................... -- . . -- . CStrings.Strlen . SPEC -- . . -- ................................................... function Strlen (String1 : in STRING) -- Ada or C return NATURAL; pragma inline (Strlen); --| Purpose --| Strlen returns the number of characters in String1, --| not including the null-terminating character. --| --| Exceptions (none) -- ................................................... -- . . -- . CStrings.Strchr . SPEC -- . . -- ................................................... function Strchr (String1 : in STRING; -- Ada or C Char1 : in CHARACTER) return NATURAL; --| Purpose --| Strchr returns the index of the first occurrence --| of Char1 in the string String1 or the value 0 if --| Char1 does not occur in String1. The null-terminating --| character is considered to be part of String1. --| --| Exceptions (none) --| --| Notes --| This function is identical to the index and strchr --| functions in C. -- ................................................... -- . . -- . CStrings.Strrchr . SPEC -- . . -- ................................................... function Strrchr (String1 : in STRING; -- Ada or C Char1 : in CHARACTER) return NATURAL; --| Purpose --| Strrchr returns the index of the last occurrence --| of Char1 in the string String1 or the value 0 if --| Char1 does not occur in String1. The null-terminating --| character is considered to be part of String1. --| --| Exceptions (none) --| --| Notes --| This function is identical to the rindex and strrchr --| functions in C. -- ................................................... -- . . -- . CStrings.Strpbrk . SPEC -- . . -- ................................................... function Strpbrk (String1 : in STRING; -- Ada or C String2 : in STRING) -- Ada or C return NATURAL; --| Purpose --| Strpbrk returns the index of the first occurrence in --| String1 of any character from String2 or the value 0 if --| no character from String2 exists in String1. --| --| Exceptions (none) -- ................................................... -- . . -- . CStrings.Strspn . SPEC -- . . -- ................................................... function Strspn (String1 : in STRING; -- Ada or C String2 : in STRING) -- Ada or C return NATURAL; --| Purpose --| Strspn returns the length of the initial segment --| of String1 which consists entirely of characters --| from String2. --| --| Exceptions (none) -- ................................................... -- . . -- . CStrings.Strcspn . SPEC -- . . -- ................................................... function Strcspn (String1 : in STRING; -- Ada or C String2 : in STRING) -- Ada or C return NATURAL; --| Purpose --| Strcspn returns the length of the initial segment --| of String1 which consists entirely of characters --| not from String2. --| --| Exceptions (none) -- ................................................... -- . . -- . CStrings.Strtok . SPEC -- . . -- ................................................... procedure Strtok (Target : in STRING; -- Ada or C Start : in out NATURAL; Delimiters : in STRING; -- Ada or C Next_Token : out STRING); -- C --| Purpose --| Strtok considers the string Target to consist of a --| sequence of zero or more text tokens separated by spans --| of one or more characters from the separator string --| Delimiters. A call to Strtok returns the first token --| in Target on or after the character indexed by Start. --| This token is returned in the string Next_Token with --| a null character immediately following the token. --| The separator string Delimiters may be different from --| call to call. --| --| Strtok must be called with Start's actual parameter --| being an initialized variable; generally, Start's --| initial value is Target'FIRST. --| --| Exceptions --| LENGTH_ERROR -- Next_Token is too short to hold --| the result end CStrings; --:::::::::: --darray.spc --:::::::::: -- ************************************************** -- * * -- * DARRAY_PKG * SPEC -- * * -- ************************************************** generic type ELEM_TYPE is private; with function Equal (E1, E2: ELEM_TYPE) return BOOLEAN is "="; package Darray_Pkg is --| Purpose --| This package provides the dynamic array (darray) abstract data type. --| A darray has completely dynamic bounds, which change during runtime as --| elements are added to/removed from the top/bottom. darrays are similar --| to deques, differing only in that operations for indexing into the --| structure are also provided. A darray is indexed by integers that --| fall within the current bounds. The component type, elem_type, of a --| darray is a generic formal parameter of this package, along with a --| function, equal, that is assumed to form an equality relation over --| over elem_type. --| --| The notation, <first, elts>, will be used to denote a darray. --| first is the current low bound of the darray. elts is the sequence --| of elements contained in the darray. For a given darray, d, the --| dot selection mechanism is used to refer to these components, e.g., --| d.first and d.elts. & is used for sequence concatenation, and also --| for prepending/postpending a single element to a sequence. |s| is --| the number of elements in a sequence, s, and () is the null sequence. --| Standard Ada array indexing notation is adopted for sequences. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Programmer: Ron Kownacki, Intermetrics -- Primary Types type DARRAY is private; type ARRAY_TYPE is array (INTEGER range <>) of ELEM_TYPE; -- Storage Management Constants and Types (see create procedure) Default_Predict : constant POSITIVE := 100; Default_High : constant POSITIVE := 50; Default_Expand : constant POSITIVE := 100; -- Exceptions No_More : exception; -- Raised on incorrect use of an iterator. Out_of_Bounds : exception; -- Raised on index out of current bounds. Uninitialized_Darray : exception; -- Raised on use of uninitialized darray by most operations. -- Iterators type ELEMENTS_ITER is private; -- Constructors -- ................................................... -- . . -- . DARRAY_PKG.CREATE . SPEC -- . . -- ................................................... procedure Create(First: in INTEGER := 1; Predict: in POSITIVE := Default_Predict; High_Percent: in POSITIVE := Default_High; Expand_Percent: in POSITIVE := Default_Expand; D: in out DARRAY); --| Purpose --| Sets d to <first, ()>. If d has previously been initialized, --| then a destroy(d) is first performed. The predict parameter --| specifies the initial space allocated. (predict = #elements). --| The high_percent parameter is the caller's expectation of the --| percentage of add_highs, out of total adds, to the darray. For --| example, a caller would specify 100 if it was known that no --| add_lows would be performed. The expand_percent parameter --| specifies the amount of additional space, as a percentage of --| currently allocated space, that is to be allocated whenever an --| expansion becomes necessary. For example, 100 doubles the --| allocated space. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.ARRAY_TO_DARRAY . SPEC -- . . -- ................................................... procedure Array_to_Darray(A: in ARRAY_TYPE; First: in INTEGER := 1; Predict: in POSITIVE; High_Percent: in POSITIVE := Default_High; Expand_Percent: in POSITIVE := Default_Expand; D: in out DARRAY); --| Purpose --| Sets d to <first, a(a'first..a'last)>. If d has previously --| been initialized, then an implicit destroy(d) is performed. --| The high_percent and expand_percent parameters are defined --| as for create. Raises out_of_bounds iff predict < a'length. --| --| Exceptions --| out_of_bounds --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.SET_FIRST . SPEC -- . . -- ................................................... procedure Set_First(D: in out DARRAY; First: in INTEGER); --| Purpose --| Sets d.first to first. --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.ADD_LOW . SPEC -- . . -- ................................................... procedure Add_Low (D: in out DARRAY; E: in ELEM_TYPE); --| Purpose --| Sets d to <d.first - 1, e & d.elts>. --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.ADD_HIGH . SPEC -- . . -- ................................................... procedure Add_High (D: in out DARRAY; E: in ELEM_TYPE); --| Purpose --| Sets d.elts to d.elts & e. --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.REMOVE_LOW . SPEC -- . . -- ................................................... procedure Remove_Low (D: in out DARRAY); --| Purpose --| Sets d to <d.first + 1, d.elts(d.first + 1 .. last(d))>. --| Raises out_of_bounds iff is_empty(d). --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| out_of_bounds --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.REMOVE_HIGH . SPEC -- . . -- ................................................... procedure Remove_High (D: in out DARRAY); --| Purpose --| Sets d.elts to d.elts(d.first..last(d) - 1). --| Raises out_of_bounds iff is_empty(d). --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| out_of_bounds --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.STORE . SPEC -- . . -- ................................................... procedure Store (D: in out DARRAY; I: in INTEGER; E: in ELEM_TYPE); --| Purpose --| Replaces d.elts(i) with e. Raises out_of_bounds iff --| either is_empty(d) or i is not in d.first..last(d). --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| out_of_bounds --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.COPY . SPEC -- . . -- ................................................... function Copy (D: DARRAY) return DARRAY; --| Purpose --| Returns a copy of d. Subsequent changes to the structure of d --| will not be visible through the application of operations to --| the copy of d, and vice versa. Assignment or parameter passing --| without using copy (or copy_deep, described below) will result --| in a single darray value being shared among objects. --| Raises uninitialized_darray if d has not been initialized. --| The assignment operation is used to transfer the values of --| the elem_type component objects of d; consequently, changes --| in these values may be observable through both darrays if --| elem_type is an access type, or contains access type --| components. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.COPY_DEEP . SPEC -- . . -- ................................................... generic with function Copy (E: ELEM_TYPE) return ELEM_TYPE; function Copy_Deep (D: DARRAY) return DARRAY; --| Purpose --| Returns a copy of d. Subsequent changes to the structure of d --| will not be visible through the application of operations to --| the copy of d, and vice versa. Assignment or parameter passing --| without using copy_deep or copy will result in a single --| darray value being shared among objects. --| Raises uninitialized_darray if d has not been initialized. --| The transfer of elem_type component objects is accomplished by --| using the assignment operation in conjunction with the copy --| function. Consequently, the user can prevent sharing of --| elem_type access components. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- Query Operations -- ................................................... -- . . -- . DARRAY_PKG.FETCH . SPEC -- . . -- ................................................... function Fetch (D: DARRAY; I: INTEGER) return ELEM_TYPE; --| Purpose --| Returns d.elts(i). Raises out_of_bounds iff either is_empty(d) --| or i is not in d.first..last(d). --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| out_of_bounds --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.LOW . SPEC -- . . -- ................................................... function Low (D: in DARRAY) return ELEM_TYPE; --| Purpose --| Returns d.elts(d.first). Raises out_of_bounds iff is_empty(d). --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| out_of_bounds --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.HIGH . SPEC -- . . -- ................................................... function High (D: in DARRAY) return ELEM_TYPE; --| Purpose --| Returns d.elts(last(d)). Raises out_of_bounds iff is_empty(d). --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| out_of_bounds --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.FIRST . SPEC -- . . -- ................................................... function First (D: in DARRAY) return INTEGER; --| Purpose --| Returns d.first. --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.LAST . SPEC -- . . -- ................................................... function Last (D: in DARRAY) return INTEGER; --| Purpose --| Returns d.first + |d.elts| - 1. --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.IS_EMPTY . SPEC -- . . -- ................................................... function Is_Empty (D: in DARRAY) return BOOLEAN; --| Purpose --| Returns length(d) = 0, or equivalently, last(d) < d.first. --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.LENGTH . SPEC -- . . -- ................................................... function Length (D: in DARRAY) return NATURAL; --| Purpose --| Returns |d.elts|. --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.EQUAL . SPEC -- . . -- ................................................... function Equal (D1, D2: DARRAY) return BOOLEAN; --| Purpose --| Return (d1.first = d2.first and --| last(d1) = last(d2) and --| for each i in d1.first..last(d1), --| equal(d1.elts(i), d2.elts(i)). --| Raises uninitialized_darray if either d1 or d2 has not been --| initialized. Note that (d1 = d2) implies that equal(d1, d2) --| will always hold. "=" is object equality, equal is state --| equality. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.DARRAY_TO_DARRAY . SPEC -- . . -- ................................................... function Darray_to_Array (D: DARRAY) return ARRAY_TYPE; --| Purpose --| Let bounds_range be d.first..d.first + length(d) - 1. If --| bounds_range is empty, then return an empty array with bounds --| of 1..0. Otherwise, return bounds_range'(d.elts). --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- Iterators -- ................................................... -- . . -- . DARRAY_PKG.MAKE_ELEMENTS_ITER . SPEC -- . . -- ................................................... function Make_Elements_Iter (D: DARRAY) return ELEMENTS_ITER; --| Purpose --| Create and return an elements itererator based on d. This --| object can then be used in conjunction with the more function --| and the next procedure to iterate over the components of d. --| Raises uninitialized_darray if d has not been initialized. --| --| Exceptions --| uninitialized_darray --| --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.MORE . SPEC -- . . -- ................................................... function More (Iter: ELEMENTS_ITER) return BOOLEAN; --| Purpose --| Return true iff the elements iterator has not been exhausted. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . DARRAY_PKG.NEXT . SPEC -- . . -- ................................................... procedure Next (Iter: in out ELEMENTS_ITER; E: out ELEM_TYPE); --| Purpose --| Let iter be based on the darray, d. Successive calls of next --| will return, in e, successive elements of d.elts. Each call --| updates the state of the elements iterator. After all elements --| have been returned, an invocation of next will raise no_more. --| Requires: --| d must not be changed between the invocations of --| make_elements_iterator(d) and next. --| --| Exceptions --| no_more --| --| Notes (none) -- Heap Management -- ................................................... -- . . -- . DARRAY_PKG.DESTROY . SPEC -- . . -- ................................................... procedure Destroy (D: in out DARRAY); --| Purpose --| Return space consumed by the darray value associated with object --| d to the heap. (If d is uninitialized, this operation does --| nothing.) If other objects share the same darray value, then --| further use of these objects is erroneous. Components of type --| elem_type, if they are access types, are not garbage collected. --| It is the user's responsibility to dispose of these objects. --| d is left in the uninitialized state. --| --| Exceptions (none) --| Notes (none) private type ARRAY_PTR is access ARRAY_TYPE; type DARRAY_INFO is record First_Idx : POSITIVE; Last_Idx : NATURAL; First : INTEGER; High_Percent : POSITIVE; Expand_Percent : POSITIVE; Arr : ARRAY_PTR := null; end record; type DARRAY is access DARRAY_INFO; -- Let r be an instance of the representation type. -- Representation Invariants: -- 1. r /= null, r.arr /= null (must be initialized to be valid.) -- 2. r.arr'first = 1 and -- r.arr'last >= 1 -- 3. r.first_idx <= r.last_idx or -- r.first_idx = r.last_idx + 1 -- 4. r.first_idx <= r.last_idx => -- r.first_idx, r.last_idx in r.arr'range -- 5. r.expand_percent, r.high_percent get values at creation time, -- and these never change. -- -- Abstraction Function: (denoted by A(r)) -- if r.last_idx < r.first_idx then -- <r.first, ()> -- else -- <r.first, (r.arr(r.first_idx),...,r.arr(r.last_idx))> -- -- These properties follow: -- 1. length(A(r)) = r.last_idx - r.first_idx + 1 -- 2. last(A(r)) = r.first + r.last_idx - r.first_idx -- 3. fetch(A(r), i) = -- if (i - r.first + r.first_idx) in r.first_idx..r.last_idx -- then r.arr(i - r.first + r.first_idx) -- else undefined. (out_of_bounds) type ELEMENTS_ITER is record Last : INTEGER := 0; Current : INTEGER := 1; Arr : ARRAY_PTR; end record; -- Let d be the darray that an elements_iter, i, is based on. -- Initially, i.current = d.first_idx, i.last = d.last_idx, and -- i.arr = d.arr. -- more(i) = i.current <= i.last. -- next(i) = i.arr(current). i.current incremented by next. -- Note that if an elements_iter object is not initialized, then -- more is false. end Darray_Pkg; --:::::::::: --dlist.spc --:::::::::: -- ***************************************************************** -- * * -- * DOUBLY_LINKED_LIST * SPEC -- * * -- ***************************************************************** generic type ELEMENT_OBJECT is private; package Doubly_Linked_List is --| Purpose --| DOUBLY_LINKED_LIST manipulates the abstract data type --| LIST_ID, which is a linked list of objects. --| DOUBLE_LIST provides routines to add objects to, --| delete objects from, and extract objects from --| the list. DOUBLE_LIST also allows the user to --| move about through the list and manipulate the --| list in various ways. --| --| Initialization Exceptions (none) --| --| Notes --| The number of list elements is restricted to --| INTEGER'LAST and the amount of memory or virtual --| memory in the computer system. --| --| Modifications --| Author: Richard Conn -- Types type ELEMENT_POSITION is new INTEGER range 0 .. INTEGER'LAST; type LIST_ID is limited private; -- Exceptions ADVANCE_PAST_END_OF_LIST : exception; BACKUP_BEFORE_BEGINNING_OF_LIST : exception; DYNAMIC_MEMORY_ALLOCATION_PROBLEM : exception; LIST_IS_EMPTY : exception; INVALID_INDEX : exception; UNEXPECTED_ERROR : exception; -- raised anytime -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.INITIALIZE . SPEC -- . . -- ............................................................. procedure Initialize (ID : in out LIST_ID); --| Purpose --| Initialize the list to empty (the list is empty when --| first used); if the list contained any elements, they --| are deleted. --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.FIRST_ELEMENT . SPEC -- . . -- ............................................................. function First_Element (ID : in LIST_ID) return ELEMENT_OBJECT; --| Purpose --| Return the first element of the list. --| --| Exceptions --| LIST_IS_EMPTY --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.LAST_ELEMENT . SPEC -- . . -- ............................................................. function Last_Element (ID : in LIST_ID) return ELEMENT_OBJECT; --| Purpose --| Return the last element of the list. --| --| Exceptions --| LIST_IS_EMPTY --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.CURRENT_ELEMENT . SPEC -- . . -- ............................................................. function Current_Element (ID : in LIST_ID) return ELEMENT_OBJECT; --| Purpose --| Return the current element of the list. --| --| Exceptions --| LIST_IS_EMPTY --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.GOTO_FIRST . SPEC -- . . -- ............................................................. procedure Goto_First (ID : in out LIST_ID); --| Purpose --| Set the current element of the list to be the first --| element. --| --| Exceptions --| LIST_IS_EMPTY --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.GOTO_LAST . SPEC -- . . -- ............................................................. procedure Goto_Last (ID : in out LIST_ID); --| Purpose --| Set the current element of the list to be the last --| element. --| --| Exceptions --| LIST_IS_EMPTY --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.GOTO_ELEMENT . SPEC -- . . -- ............................................................. procedure Goto_Element (ID : in out LIST_ID; Index : in ELEMENT_POSITION); --| Purpose --| Set the current element of the list to be the Nth (INDEX) --| element. --| --| Exceptions --| INVALID_INDEX --| LIST_IS_EMPTY --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.CURRENT_INDEX . SPEC -- . . -- ............................................................. function Current_Index (ID : in LIST_ID) return ELEMENT_POSITION; --| Purpose --| Return the number of the current element. --| --| Exceptions --| LIST_IS_EMPTY --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.LAST_INDEX . SPEC -- . . -- ............................................................. function Last_Index (ID : in LIST_ID) return ELEMENT_POSITION; --| Purpose --| Return the number of the last element. --| --| Exceptions --| LIST_IS_EMPTY --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.ADVANCE . SPEC -- . . -- ............................................................. procedure Advance (ID : in out LIST_ID); --| Purpose --| Advance, setting the current element to be the next --| element. --| --| Exceptions --| ADVANCE_PAST_END_OF_LIST --| LIST_IS_EMPTY --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.BACKUP . SPEC -- . . -- ............................................................. procedure Backup (ID : in out LIST_ID); --| Purpose --| Backup, setting the current element to be the previous --| element. --| --| Exceptions --| BACKUP_BEFORE_BEGINNING_OF_LIST --| LIST_IS_EMPTY --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.IS_EMPTY . SPEC -- . . -- ............................................................. function Is_Empty (ID : in LIST_ID) return BOOLEAN; --| Purpose --| Return TRUE if the list is empty. --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.IS_END . SPEC -- . . -- ............................................................. function Is_End (ID : in LIST_ID) return BOOLEAN; --| Purpose --| Return TRUE if the end of the list has been passed. --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.IS_FIRST . SPEC -- . . -- ............................................................. function Is_First (ID : in LIST_ID) return BOOLEAN; --| Purpose --| Return TRUE if the current element is the first element. --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.APPEND_ELEMENT . SPEC -- . . -- ............................................................. procedure Append_Element (ID : in out LIST_ID; Element : ELEMENT_OBJECT); --| Purpose --| Append an element after the current element; set the current --| element to this new element. --| --| Exceptions --| DYNAMIC_MEMORY_ALLOCATION_PROBLEM --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.INSERT_ELEMENT . SPEC -- . . -- ............................................................. procedure Insert_Element (ID : in out LIST_ID; Element : ELEMENT_OBJECT); --| Purpose --| Insert an element before the current element; the current --| element remains unchanged. --| --| Exceptions --| DYNAMIC_MEMORY_ALLOCATION_PROBLEM --| --| Notes (none) -- ............................................................. -- . . -- . DOUBLY_LINKED_LIST.DELETE_ELEMENT . SPEC -- . . -- ............................................................. procedure Delete_Element (ID : in out LIST_ID); --| Purpose --| Delete the current element; the current element becomes the --| element following the current element. --| --| Exceptions --| ADVANCE_PAST_END_OF_LIST --| LIST_IS_EMPTY --| --| Notes (none) private type ELEMENT; type ELEMENT_POINTER is access ELEMENT; type ELEMENT is record Content : ELEMENT_OBJECT; Next : ELEMENT_POINTER; Previous : ELEMENT_POINTER; end record; type LIST_ID is record First : ELEMENT_POINTER := null; -- first element Last : ELEMENT_POINTER := null; -- last element Current : ELEMENT_POINTER := null; -- current element Free : ELEMENT_POINTER := null; -- free element list Number_of_Elements : ELEMENT_POSITION := 0; -- number of elements Current_Index : ELEMENT_POSITION := 0; -- index of current element end record; end Doubly_Linked_List; --:::::::::: --dyn.spc --:::::::::: -- ******************************************************* -- * * -- * DYN * SPEC -- * * -- ******************************************************* package Dyn is --| Purpose --| Implement a dynamic string object class and provide operations --| to manipulate objects of this class. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| This is a package of several string manipulation functions based on --| a built-in dynamic STRING type DYN_STRING. It is an adaptation and --| extension of the package proposed by Sylvan Rubin of Ford Aerospace and --| Communications Corporation in the Nov/Dec 1984 issue of the Journal of --| Pascal, Ada and Modula-2. Some new functions have been added, and much --| of the body code has been rewritten. --| --| This package is derived from DSTR3.SRC in the Ada Software Repository --| DSTR3.SRC was written by R.G. Cleaveland. The derivation, done by --| Richard Conn, was done to remove those general-purpose features of the --| package not needed for the PTF project. Max_D_String_Length : constant POSITIVE := 100; -- This is the maximum LENGTH of a dynamic string implemented with this -- package. This value is "arbitrary" in that any reasonable number -- equal to or less than the maximum STRING LENGTH permitted by the -- compiler is acceptable. The specific value above was chosen as a -- compromise between programmer convenience and memory space requirements. subtype DS_POS is INTEGER range 0..MAX_D_STRING_LENGTH; type DYN_STRING is private; STRING_TOO_SHORT: exception; -- .................................................. -- . . -- . DYN.D_STRING . SPEC -- . . -- .................................................. function D_String (Char: CHARACTER) return DYN_STRING; --| Purpose --| Creates a one-byte dynamic string of contents CHAR. --| --| Exceptions (none) --| Notes (none) -- .................................................. -- . . -- . DYN.D_STRING . SPEC -- . . -- .................................................. function D_String (Str : STRING) return DYN_STRING; --| Purpose --| Creates a dynamic string of contents STR. --| --| Exceptions (none) --| Notes (none) -- .................................................. -- . . -- . DYN.CHAR . SPEC -- . . -- .................................................. function Char (Dstr : DYN_STRING; Posit : POSITIVE := 1) return CHARACTER; --| Purpose --| Return the Nth character of a dynamic string. --| --| Exceptions --| STRING_TOO_SHORT --| --| Notes (none) -- .................................................. -- . . -- . DYN.STR . SPEC -- . . -- .................................................. function Str (Dstr: DYN_STRING) return STRING; --| Purpose --| Return the string whose contents is the value of a dynamic --| string. --| --| Exceptions (none) --| Notes (none) -- .................................................. -- . . -- . DYN.LENGTH . SPEC -- . . -- .................................................. function Length (Dstr: DYN_STRING) return NATURAL; --| Purpose --| Returns the LENGTH of the dynamic string. --| --| Exceptions (none) --| Notes (none) -- .................................................. -- . . -- . DYN.CLEAR . SPEC -- . . -- .................................................. procedure Clear (Dstr: in out DYN_STRING); --| Purpose --| Makes DSTR a null string. --| --| Exceptions (none) --| Notes (none) private type DYN_STRING is record Size : INTEGER range 0..MAX_D_STRING_LENGTH; Data : STRING(1..MAX_D_STRING_LENGTH); end record; end Dyn; --:::::::::: --fof.spc --:::::::::: -- ********************************** -- * * -- * Formatted_Output_File (FOF) * SPEC -- * * -- ********************************** package Formatted_Output_File is --| Purpose --| Formatted_Output_File manipulates objects of type STRING (text), --| placing text into the output file as it is received. --| Formatted_Output_File is also used to define the format of the --| text (number of lines per page, header, footer, etc.). --| --| Formatted_Output_File is a form of Report Generator. Taking in --| raw text and other directives (implemented by its procedures), --| Formatted_Output_File creates reports (with header lines, footer --| lines, page numbering, etc). --| --| Formatted_Output_File is also referred to as FOF. --| --| See the test programs for examples of the use of FOF. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| 04/22/90 Rick Conn Initial version from PTF's FOF --| package of 8/16/89 type FILE is private; Maximum_Number_Of_Lines_On_Page : constant := 200; Maximum_Line_Length : constant := 200; Maximum_Number_Of_Header_Footer_Lines : constant := 8; Maximum_Number_Of_Pages : constant := 32000; type PAGE_ATTRIBUTE is ( TOP_MARGIN, -- Number of lines before first header BOTTOM_MARGIN, -- Number of lines after last footer LEFT_MARGIN, -- Column num of the last col before the 1st char RIGHT_MARGIN, -- Column number of the last char of the line LEFT_INDENT, -- Number of columns to indent from LEFT_MARGIN RIGHT_INDENT, -- Number of columns to indent from RIGHT_MARGIN TOTAL_LINES, -- Number of lines on a page HEADER_LINES, -- Number of lines in the header FOOTER_LINES, -- Number of lines in the footer LINE_SPACING, -- Number of blank lines after each text line PAGE_OFFSET, -- Number of columns to offset each line TEMP_INDENT -- Number of columns to indent next line only -- (this is an absolute value, not influenced -- by the LEFT_MARGIN or LEFT_INDENT settings) ); type LINE_ATTRIBUTE is ( BOLD, -- Make words come out bold (overstrike) CENTER, -- Center lines (Put_Line with No Fill) FILL, -- Successively place words into an output -- line until the next word will not fit -- between the left and right margins -- (with indents) FILL_STATE_BEFORE_CENTER, -- Save area for FILL JUSTIFY, -- Fill output line to RIGHT_MARGIN - -- RIGHT_INDENT with spaces between words PAGING, -- Break output on page boundaries, -- outputting footer, bottom margin, -- top margin, and header UNDERLINE, -- Underline words UNDERLINE_PUNCT, -- If ON, underline punctuation USE_FORM_FEED -- Use form feeds to eject pages ); type PAGE_ATTRIBUTE_LIST is array (PAGE_ATTRIBUTE) of NATURAL; type OFF_ON is ( OFF, ON ); type LINE_ATTRIBUTE_LIST is array (LINE_ATTRIBUTE) of OFF_ON; Page_Attribute_Defaults : constant PAGE_ATTRIBUTE_LIST := ( TOP_MARGIN => 4, BOTTOM_MARGIN => 4, LEFT_MARGIN => 12, RIGHT_MARGIN => 90, LEFT_INDENT => 0, RIGHT_INDENT => 0, TOTAL_LINES => 66, HEADER_LINES => 2, FOOTER_LINES => 2, LINE_SPACING => 0, PAGE_OFFSET => 0, TEMP_INDENT => 0 ); Line_Attribute_Defaults : constant LINE_ATTRIBUTE_LIST := ( BOLD => OFF, CENTER => OFF, FILL => ON, FILL_STATE_BEFORE_CENTER => ON, JUSTIFY => ON, PAGING => ON, UNDERLINE => OFF, UNDERLINE_PUNCT => OFF, USE_FORM_FEED => ON ); Page_Number_Id_Default : constant CHARACTER := '#'; type LINE_NUMBER is new INTEGER range 0 .. Maximum_Number_Of_Lines_On_Page; type HEADER_FOOTER_LINE is -- H/F line numbers new INTEGER range 1 .. Maximum_Number_Of_Header_Footer_Lines; type PAGE_NUMBER is new INTEGER range 0 .. Maximum_Number_Of_Pages; type STATUS is -- for Open ( OK, NOT_OK ); type PAGE_SIDE is -- for margins and indents ( LEFT_SIDE, RIGHT_SIDE ); type PAGE_KIND is -- for headers and footers ( EVEN_PAGES, ODD_PAGES, ALL_PAGES ); type NUMERIC_FORMAT is -- for page numbers ( ARABIC, LOWER_ROMAN, UPPER_ROMAN ); Range_Error : exception; File_Not_Open : exception; -- .................................. -- . . -- . FOF.Open . SPEC -- . . -- .................................. procedure Open ( Item : in out FILE; File_Name : in STRING; Result : out STATUS ); --| Purpose --| Open the formatted output file for subsequent processing. --| --| Exceptions (none) --| Notes (none) -- .................................. -- . . -- . FOF.Close . SPEC -- . . -- .................................. procedure Close ( Item : in FILE ); --| Purpose --| Close the formatted output file. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Put_Invisible_Word . SPEC -- . . -- .................................. procedure Put_Invisible_Word ( Item : in FILE; What : in STRING ); --| Purpose --| Add a word to the current line and do not increment the --| character count. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Put_Word . SPEC -- . . -- .................................. procedure Put_Word ( Item : in FILE; What : in STRING ); --| Purpose --| Add a word to the current line. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Put_Line . SPEC -- . . -- .................................. procedure Put_Line ( Item : in FILE; What : in STRING ); --| Purpose --| Add a line to the current page. If line break, insert blank --| lines as per LINE_SPACING. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Break_Line . SPEC -- . . -- .................................. procedure Break_Line ( Item : in FILE ); --| Purpose --| Break the current line (if it contains any words, output them). --| Insert blank lines as per the LINE_SPACING setting. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Current_Line . SPEC -- . . -- .................................. function Current_Line ( Item : in FILE ) return LINE_NUMBER; --| Purpose --| Return the number of the current line. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Skip . SPEC -- . . -- .................................. procedure Skip ( Item : in FILE; Number_Of_Lines : in LINE_NUMBER := 1 ); --| Purpose --| Skip Number_Of_Lines in the output after first issuing a Break_Line. --| LINE_SPACING influences the actual number of lines skipped. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Break_Page . SPEC -- . . -- .................................. procedure Break_Page ( Item : in FILE ); --| Purpose --| If there is anything on the current page, output it and advance --| to the next page. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Break_Page . SPEC -- . . -- .................................. procedure Break_Page ( Item : in FILE; New_Page_Num : in PAGE_NUMBER ); --| Purpose --| If there is anything on the current page, output it and advance --| to the next page. Set the number of the next page to New_Page_Num. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Current_Page . SPEC -- . . -- .................................. function Current_Page ( Item : in FILE ) return PAGE_NUMBER; --| Purpose --| Return the number of the current page. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Current_Page . SPEC -- . . -- .................................. function Current_Page ( Item : in FILE ) return STRING; --| Purpose --| Return the number of the current page as a string. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Set_Page_Number_Format . SPEC -- . . -- .................................. procedure Set_Page_Number_Format ( Item : in FILE; To : in NUMERIC_FORMAT; Format_String : in STRING ); --| Purpose --| Set the format of the page number. If the Format_String is not --| null, the page numbers in the headers and footers will appear as --| indicated (with the literal number substituted for # characters). --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Set_Page_Attribute . SPEC -- . . -- .................................. procedure Set_Page_Attribute ( Item : in FILE; What : in PAGE_ATTRIBUTE; To : in NATURAL ); --| Purpose --| Set a specified page attribute. --| --| Exceptions --| Range_Error raised if To is outside the range for What --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Set_Line_Attribute . SPEC -- . . -- .................................. procedure Set_Line_Attribute ( Item : in FILE; What : in LINE_ATTRIBUTE; To : in OFF_ON ); --| Purpose --| Turn off or on the indicated attribute for the current and --| following lines. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Get_Page_Attribute . SPEC -- . . -- .................................. function Get_Page_Attribute ( Item : in FILE; What : in PAGE_ATTRIBUTE ) return NATURAL; --| Purpose --| Get a specified page attribute. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Get_Line_Attribute . SPEC -- . . -- .................................. function Get_Line_Attribute ( Item : in FILE; What : in LINE_ATTRIBUTE ) return OFF_ON; --| Purpose --| Get the indicated attribute for the current and --| following lines. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Test_Page . SPEC -- . . -- .................................. function Test_Page ( Item : in FILE; Number_Of_Lines : in LINE_NUMBER ) return BOOLEAN; --| Purpose --| Return TRUE if Number_Of_Lines is remaining on the current page. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Set_Footer_Line . SPEC -- . . -- .................................. procedure Set_Footer_Line ( Item : in FILE; Class : in PAGE_KIND; Number : in HEADER_FOOTER_LINE; Left_Text : in STRING; Center_Text : in STRING; Right_Text : in STRING ); --| Purpose --| Store a footer line for EVEN, ODD, or ALL pages. --| The footer line is dynamically adjusted, based on the left and right --| margin settings. The strings Left, Center, and Right are left- --| justified, centered, and right-justified in the indicated footer --| line, respectively. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Set_Header_Line . SPEC -- . . -- .................................. procedure Set_Header_Line ( Item : in FILE; Class : in PAGE_KIND; Number : in HEADER_FOOTER_LINE; Left_Text : in STRING; Center_Text : in STRING; Right_Text : in STRING ); --| Purpose --| Store a header line for EVEN, ODD, or ALL pages. --| The header line is dynamically adjusted, based on the left and right --| margin settings. The strings Left, Center, and Right are left- --| justified, centered, and right-justified in the indicated header --| line, respectively. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Set_Page_Number_Id . SPEC -- . . -- .................................. procedure Set_Page_Number_Id ( Item : in FILE; To : in CHARACTER ); --| Purpose --| Set the character used to represent the page number in the --| header and footer lines of the output file. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Set_Page_Number_Format . SPEC -- . . -- .................................. procedure Set_Page_Number_Format ( Item : in FILE; To : in NUMERIC_FORMAT ); --| Purpose --| Set the format used to represent the page number in the --| header and footer lines of the output file. --| --| Exceptions --| File_Not_Open --| --| Notes (none) -- .................................. -- . . -- . FOF.Page_Number_Format . SPEC -- . . -- .................................. function Page_Number_Format ( Item : in FILE ) return NUMERIC_FORMAT; --| Purpose --| Get the format used to represent the page number in the --| header and footer lines of the output file. --| --| Exceptions --| File_Not_Open --| --| Notes (none) private -- Formatted_Output_File type FILE_OBJECT; type FILE is access FILE_OBJECT; end Formatted_Output_File; --:::::::::: --hashfcns.spc --:::::::::: -- ********************************************************* -- * * -- * Hashing_Functions_PKG * SPEC -- * * -- ********************************************************* package Hashing_Functions_PKG is --| Purpose --| Provide a string hashing function. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Bill Toscano and Michael Gordon, Intermetrics generic Prime_Num: in POSITIVE; -- Required to be prime function Hash_String (S: STRING) return NATURAL; --| Purpose --| Produces a uniform distribution over the range 0..prime - 1. --| --| Exceptions (none) --| Notes (none) end Hashing_Functions_PKG; --:::::::::: --in.spc --:::::::::: -- ********************************** -- * * -- * Input_File * SPEC -- * * -- ********************************** package Input_File is --| Purpose --| Input_File implements an abstract data type of an input file. --| Input_File offers an abstraction that can be made more efficient --| by not using Text_IO (and having its associated overhead imposed) --| if possible, --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version type FILE_TYPE is private; Cannot_Open_Input_File : exception; Read_Error : exception; -- .................................. -- . . -- . Input_File.Open . SPEC -- . . -- .................................. procedure Open ( Id : in out FILE_TYPE; File_Name : in STRING ); --| Purpose --| Open an existing FILE_TYPE object. --| --| Exceptions --| Cannot_Open_Input_File --| --| Notes (none) -- .................................. -- . . -- . Input_File.Get_Line . SPEC -- . . -- .................................. procedure Get_Line ( Id : in out FILE_TYPE; Item : out STRING; Last : out NATURAL ); --| Purpose --| Get_Line reads an Item to the FILE_TYPE object. --| --| Exceptions --| Read_Error --| --| Notes (none) -- .................................. -- . . -- . Input_File.End_Of_File . SPEC -- . . -- .................................. function End_Of_File ( Id : in FILE_TYPE ) return BOOLEAN; --| Purpose --| End_Of_File returns TRUE if the FILE_TYPE object is empty or --| no more data is in it. --| --| Exceptions --| Read_Error --| --| Notes (none) -- .................................. -- . . -- . Input_File.Close . SPEC -- . . -- .................................. procedure Close ( Id : in out FILE_TYPE ); --| Purpose --| Close closes input from the FILE_TYPE object. --| --| Exceptions (none) --| Notes (none) private -- Input_File type FILE_OBJECT; type FILE_TYPE is access FILE_OBJECT; end Input_File; --:::::::::: --lists.spc --:::::::::: -- ********************************************* -- * * -- * LISTS * SPEC -- * * -- ********************************************* generic type ITEMTYPE is private; -- This is the data being manipulated. with function Equal (X,Y: in ITEMTYPE) return BOOLEAN is "="; -- This allows the user to define -- equality on ItemType. For instance -- if ItemType is an abstract type -- then equality is defined in terms of -- the abstract type. If this function -- is not provided equality defaults to -- =. package Lists is --| Purpose --| This package provides singly linked lists with elements of type --| ItemType, where ItemType is specified by a generic parameter. --| --| When this package is instantiated, it provides a linked list type for --| lists of objects of type ItemType, 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); --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Programmer Buddy Altus, Intermetrics 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. -- ....................................................... -- . . -- . LISTS.ATTACH . SPEC -- . . -- ....................................................... procedure Attach (List1: in out LIST; List2: in LIST); --| Purpose --| Appends List2 to List1. 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. --| --| Exceptions --| CircularList --| --| Notes -- ....................................................... -- . . -- . LISTS.ATTACH . SPEC -- . . -- ....................................................... function Attach (Element1: in ITEMTYPE; Element2: in ITEMTYPE) return LIST; --| Purpose --| This creates a list containing the two elements in the order --| specified. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.ATTACH . SPEC -- . . -- ....................................................... procedure Attach (L: in out LIST; Element: in ITEMTYPE); --| Purpose --| Appends Element onto the end of the list L. If L is empty then this --| may change the value of L. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.ATTACH . SPEC -- . . -- ....................................................... procedure Attach (Element: in ITEMTYPE; L: in out LIST); --| Purpose --| This prepends list L with Element (makes Element the first item in --| list L). --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.ATTACH . SPEC -- . . -- ....................................................... function Attach (List1: in LIST; List2: in LIST) return LIST; --| Purpose --| 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. --| --| Exceptions --| CircularList --| --| Notes (none) -- ....................................................... -- . . -- . LISTS.ATTACH . SPEC -- . . -- ....................................................... function Attach (Element: in ITEMTYPE; L: in LIST) return LIST; --| Purpose --| Returns a new list which is headed by Element and followed by L. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.ATTACH . SPEC -- . . -- ....................................................... function Attach (L: in LIST; Element: in ITEMTYPE) return LIST; --| Purpose --| Returns a new list which is L followed by Element. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.COPY . SPEC -- . . -- ....................................................... function Copy (L: in LIST) return LIST; --| Purpose --| Returns a copy of L. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.COPYDEEP . SPEC -- . . -- ....................................................... generic with function Copy (I: in ITEMTYPE) return ITEMTYPE; function CopyDeep (L: in LIST) return LIST; --| Purpose --| This produces a new list whose elements have been duplicated using --| the Copy function provided by the user. This is helpful if the type --| of a list is an abstract data type. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.CREATE . SPEC -- . . -- ....................................................... function Create return LIST; --| Purpose --| Returns an empty, initialized list. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.DELETEHEAD . SPEC -- . . -- ....................................................... procedure DeleteHead (L: in out LIST); --| Purpose --| 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. --| --| Exceptions --| EmptyList --| --| Notes (none) -- ....................................................... -- . . -- . LISTS.DELETEITEM . SPEC -- . . -- ....................................................... procedure DeleteItem (L: in out LIST; Element: in ITEMTYPE); --| Purpose --| Removes the first element of the list equal to Element. If there is --| not an element equal to Element, then ItemNotPresent is raised. --| --| This operation is destructive; it returns the storage occupied by --| the elements being deleted. --| --| Exceptions --| ItemNotPresent --| --| Notes (none) -- ....................................................... -- . . -- . LISTS.DELETEITEM . SPEC -- . . -- ....................................................... function DeleteItem (L: in LIST; Element: in ITEMTYPE) return LIST; --| Purpose --| This returns the List L with the first occurrence of Element removed. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.DELETEITEMS . SPEC -- . . -- ....................................................... function DeleteItems (L: in LIST; Element: in ITEMTYPE) return LIST; --| Purpose --| This function returns a copy of the list L which has all elements which --| have value Element removed. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.DELETEITEMS . SPEC -- . . -- ....................................................... procedure DeleteItems (L: in out LIST; Element: in ITEMTYPE); --| Purpose --| This procedure removes all occurrences of Element from the List L. This --| is a destructive procedure. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.DESTROY . SPEC -- . . -- ....................................................... procedure Destroy (L: in out LIST); --| Purpose --| 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. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.DESTROYDEEP . SPEC -- . . -- ....................................................... generic with procedure Dispose (I :in out ITEMTYPE); procedure DestroyDeep (L :in out LIST); --| Purpose --| This procedure is used to destroy a list and all the objects contained --| in an element of the list. For example if L is a list of lists --| then destroy L does not destroy the lists which are elements of L. --| DestroyDeep will now destroy L and all the objects in the elements of L. --| The produce Dispose is a procedure which will destroy the objects which --| comprise an element of a list. For example if package L was a list --| of lists then Dispose for L would be the Destroy of list type package L was --| instantiated with. --| --| This procedure requires no sharing between elements of lists. --| For example, if L_int is a list of integers and L_of_L_int is a list --| of lists of integers and two elements of L_of_L_int have the same value --| then doing a DestroyDeep will cause an access violation to be raised. --| The best way to avoid this is not to have sharing between list elements --| or use copy functions when adding to the list of lists. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.FIRSTVALUE . SPEC -- . . -- ....................................................... function FirstValue (L: in LIST) return ITEMTYPE; --| Purpose --| This returns the Item in the first position in the list. If the list --| is empty EmptyList is raised. --| --| Exceptions --| EmptyList --| --| Notes (none) -- ....................................................... -- . . -- . LISTS.FORWARD . SPEC -- . . -- ....................................................... procedure Forward (I :in out LISTITER); --| Purpose --| This procedure can be used in conjunction with Cell to iterate over a list. --| This is in addition to Next. Instead of writing --| --| I :ListIter; --| L :List; --| V :List_Element_Type; --| --| I := MakeListIter(L); --| while More(I) loop --| Next (I, V); --| Print (V); --| end loop; --| --| One can write --| --| I := MakeListIter(L); --| while More (I) loop --| Print (Cell (I)); --| Forward (I); --| end loop; --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.ISEMPTY . SPEC -- . . -- ....................................................... function IsEmpty (L: in LIST) return BOOLEAN; --| Purpose --| Return TRUE iff L is empty. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.ISINLIST . SPEC -- . . -- ....................................................... function IsInList (L: in LIST; Element: in ITEMTYPE) return BOOLEAN; --| Purpose --| Walks down the list L looking for an element whose value is Element. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.LASTVALUE . SPEC -- . . -- ....................................................... function LastValue (L: in LIST) return ITEMTYPE; --| Purpose --| Returns the last element in a list. If the list is empty EmptyList is --| raised. --| --| Exceptions --| EmptyList --| --| Notes (none) -- ....................................................... -- . . -- . LISTS.LENGTH . SPEC -- . . -- ....................................................... function Length (L: in LIST) return INTEGER; --| Purpose --| Count the number of elements in list L. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.LENGTH . SPEC -- . . -- ....................................................... function MakeList (E :in ITEMTYPE) return LIST; --| Purpose --| Takes in an element and returns a list. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.MAKELISTITER . SPEC -- . . -- ....................................................... function MakeListIter (L: in LIST) return LISTITER; --| Purpose --| 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 Next the Iter --| is updated with each call. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.MORE . SPEC -- . . -- ....................................................... function More (L: in LISTITER) return BOOLEAN; --| Purpose --| Returns TRUE iff there are more elements in the list. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.NEXT . SPEC -- . . -- ....................................................... procedure Next (Place: in out LISTITER; Info: out ITEMTYPE); --| Purpose --| This is the iterator operation. Given a ListIter, Next returns the --| current item and updates the ListIter. --| --| The iterators subprograms MakeListIter, More, and Next should be used --| in the following way: --| --| L: List; --| Place: ListIter; --| Info: SomeType; --| --| --| Place := MakeListIter(L); --| --| while ( More(Place) ) loop --| Next(Place, Info); --| process each element of list L; --| end loop; --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.REPLACEHEAD . SPEC -- . . -- ....................................................... procedure ReplaceHead (L: in out LIST; Info: in ITEMTYPE); --| Purpose --| Replaces the information in the first element in the list. Raises --| EmptyList if the list is empty. --| --| Exceptions --| EmptyList --| --| Notes (none) -- ....................................................... -- . . -- . LISTS.REPLACETAIL . SPEC -- . . -- ....................................................... procedure ReplaceTail (L: in out LIST; NewTail: in LIST); --| Purpose --| Replaces the tail of a list with a new list. If the list whose tail --| is being replaced is null EmptyList is raised. --| --| Exceptions --| EmptyList --| --| Notes (none) -- ....................................................... -- . . -- . LISTS.TAIL . SPEC -- . . -- ....................................................... function Tail (L: in LIST) return LIST; --| Purpose --| 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. --| --| Exceptions --| EmptyList --| --| Notes (none) -- ....................................................... -- . . -- . LISTS.CELLVALUE . SPEC -- . . -- ....................................................... function CellValue (I :in LISTITER) return ITEMTYPE; --| Purpose --| This returns the value of the element at the position of the iterator. --| This is used in conjunction with Forward. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . LISTS.EQUAL . SPEC -- . . -- ....................................................... function Equal (List1: in LIST; List2: in LIST) return BOOLEAN; --| Purpose --| 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. --| --| Exceptions (none) --| Notes (none) 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 : ITEMTYPE; Next : LIST; end record; type LISTITER is new LIST; -- This prevents Lists being assigned to -- iterators and vice versa end Lists; --:::::::::: --logical.spc --:::::::::: -- *************************************************************** -- * * -- * LOGICAL * SPEC -- * * -- *************************************************************** package Logical is --| Purpose --| LOGICAL provides bit-level manipulation on INTEGER objects. --| --| Initialization Exceptions (none) --| Notes --| Not all MIL-HDBK-1804 PDL annotations are --| used in this package due to its simplicity. --| No exceptions are raised by this package. --| --| Modifications --| Author: Joseph Orost, Concurrent Computer Corporation -- .................................................................. -- . . -- . LOGICAL.ROTATE . SPEC -- . . -- .................................................................. function Rotate (Arg, Count : INTEGER) return INTEGER; --| Purpose --| Return arg rotated count bits. --| If count < 0, rotate is to the right, --| else, rotate is to the left. -- .................................................................. -- . . -- . LOGICAL.SHIFT . SPEC -- . . -- .................................................................. function Shift (Arg, Count : INTEGER) return INTEGER; --| Purpose --| Return arg logically shifted count bits. --| Bits shifted out either end are lost. --| If count < 0, shift is to the right, --| else, shift is to the left -- .................................................................. -- . . -- . LOGICAL."xor" . SPEC -- . . -- .................................................................. function "xor" (Left, Right : INTEGER) return INTEGER; --| Purpose --| Return left XOR right. -- .................................................................. -- . . -- . LOGICAL."and" . SPEC -- . . -- .................................................................. function "and" (Left, Right : INTEGER) return INTEGER; --| Purpose --| Return left AND right. -- .................................................................. -- . . -- . LOGICAL."or" . SPEC -- . . -- .................................................................. function "or" (Left, Right : INTEGER) return INTEGER; --| Purpose --| Return left OR right. -- .................................................................. -- . . -- . LOGICAL."not" . SPEC -- . . -- .................................................................. function "not" (Right : INTEGER) return INTEGER; --| Purpose --| Return NOT right. end Logical; --:::::::::: --lparse.spc --:::::::::: -- ***************************************************** -- * * -- * LINE_PARSER * SPEC -- * * -- ***************************************************** package Line_Parser is --| Purpose --| Line_Parser parses strings in a manner similar to ARGC/ARGV --| under UNIX. Function ARGC returns a count of the number of --| tokens in the string and function ARGV returns each token --| as a separate substring. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Richard Conn -- ................................................. -- . . -- . LINE_PARSER.INITIALIZE . SPEC -- . . -- ................................................. procedure Initialize (Item : in STRING); --| Purpose --| Initialize this package. This routine MUST be called --| before any other routines. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LINE_PARSER.ARGC . SPEC -- . . -- .................................................... function ArgC return NATURAL; --| Purpose --| Return the number of tokens in the string. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . LINE_PARSER.ARGV . SPEC -- . . -- ................................................... function ArgV (Index : in NATURAL) return STRING; --| Purpose --| Return the Nth token in the string (the first token is --| numbered 0). Valid values for INDEX are from 0 to --| ARGC-1. --| --| Exceptions --| INVALID_INDEX is raised if INDEX > ARGC-1 --| --| Notes (none) INVALID_INDEX : exception; UNEXPECTED_ERROR : exception; end Line_Parser; --:::::::::: --matrix.spc --:::::::::: -- **************************************************************** -- * * -- * Matrix_Package * SPEC -- * * -- **************************************************************** package MATRIX_PACKAGE is --| Purpose --| This package is a general purpose matrix package. It defines data --| types VECTOR and MATRIX, and contains functions to perform general --| matrix algebra operations. --| --| Initialization Exceptions (none) --| --| Notes --| Not all MIL-HDBK-1804 PDL annotations are used in this package --| due to its simplicity. --| --| Modifications --| Author: Dr. Roger Lee, Naval Air Development Center --| Art Adamson, Consultant -- Types type VECTOR is array(integer range<>) of float ; subtype VEC2T is VECTOR (integer range 1..2) ; subtype VEC3T is VECTOR (integer range 1..3) ; type MATRIX is array(integer range<>,integer range <>) of float; type MATR2T is array(integer range<>) of VEC2T; -- Exceptions INCOMPARABLE_DIMENSION :exception; -- the dimension of matrices -- or vectors to be operated are -- incomparable SINGULAR : exception; -- matrix to be inverted is singular -- Operations function TRANSPOSE(A : MATRIX) return MATRIX ; -- transpose of matrix function TRANSPOSE(A : VECTOR) return VECTOR ; -- transpose of vector function "+" (A : VECTOR; B : VECTOR) return VECTOR ; -- sum of vector function "+" (A : MATRIX; B : MATRIX) return MATRIX ; -- sum of matrix function "+" (A : float; B : VECTOR) return VECTOR ; -- float added to, each term of matrix function "+" (A : VEC2T; B : MATR2T) return MATR2T ; -- Vec2T added to, each term of MATR2T function "+" (A : MATR2T; B : MATR2T) return MATR2T ; -- Corressponding terms added. function "-" (A : VECTOR; B : VECTOR) return VECTOR ; -- difference of vector function "-" (A : MATRIX; B : MATRIX) return MATRIX ; -- difference of matrix function "*" (A : float; B : VECTOR) return VECTOR ; -- scalar, vector multiplication function "*" (A : VECTOR; B : float) return VECTOR ; -- vector, scalar multiplication function "*" (A : VECTOR; B : VECTOR) return float ; -- inner(dot) product of two vectors function "*" (A : MATRIX; B : VECTOR) return VECTOR ; -- matrix,column vector multiplication function mat4mult(UL : MATRIX; UR : MATRIX; BL : MATRIX; BR : MATRIX; B : VECTOR) return VECTOR ; -- large matrix broken into 4 smaller ones, column vector multiplication -- (upper left, upper right, bottom left, bottom right--all square) function "*" (A : VECTOR; B : MATRIX) return VECTOR ; -- row vector,matrix multiplication function "*" (A : float; B : MATRIX) return MATRIX ; -- scalar, matrix multiplication function "*" (A : MATRIX; B : float) return MATRIX ; -- matrix, scalar multiplication function "*" (A : MATRIX; B : MATRIX) return MATRIX ; -- matrix, matrix multiplication function "*" (A : float; B : MATR2T) return MATR2T ; -- Multiplies each term of a MATR2T by a float function "*" (A : VEC2T; B : MATR2T) return VECTOR ; -- Dot product of each term of MATR2T by a VEC2T, return array of floats function "*" (A : VECTOR; B : MATR2T) return MATR2T ; --Multiplies each term of VEC2T by a corresponding float from a VECTOR function "**"(A : MATRIX; P : integer) return MATRIX; -- square matrix raised to integer power -- if P = -1, we invert the matrix function "**" (A : VECTOR; B : VECTOR) return VECTOR ; -- A X B = ab sin(theta) a direction --perpendicular to plane of A & B. function JCROSS (A : VEC2T) return VEC2T ; --Rotates Vec2T 90 degrees CW. function JCROSS (A : MATR2T) return MATR2T ; --Rotates Vec2T's 90 degrees CW. function ROTX (A : VEC2T) return VEC2T ; --Rotates Vec2T 180 degrees about the X axis. function ROTY (A : VEC2T) return VEC2T ; --Rotates Vec2T 180 degrees about the Y axis. function aXbDOTj(A : VEC2T; B : VEC2T) return FLOAT; --Gets magnitude of A cross B for 2 2D vectors. function GETTAN (A : VEC2T; B : VEC2T) return FLOAT; --Gets TAN(THETA) between 2 2D vectors. end MATRIX_PACKAGE; --:::::::::: --mlib.spc --:::::::::: -- *************************************************************** -- * * -- * FLOATING_CHARACTERISTICS * SPEC -- * * -- *************************************************************** package Floating_Characteristics is --| Purpose --| This package is a floating mantissa definition of a binary FLOAT --| It was first used on the DEC-10 and the VAX but should work for any --| since the parameters are obtained by initializing on the actual hardware. --| Otherwise the parameters could be set in the spec if known. --| This is a preliminary package that defines the properties --| of the particular floating point type for which we are going to --| generate the math routines. --| The constants are those required by the routines described in --| "Software Manual for the Elementary Functions" W. Cody & W. Waite --| Prentice-Hall 1980. --| Actually most are needed only for the test programs --| rather than the functions themselves, but might as well be here. --| Most of these could be in the form of attributes if --| all the floating types to be considered were those built into the --| compiler, but we also want to be able to support user defined types --| such as software floating types of greater precision than --| the hardware affords, or types defined on one machine to --| simulate another. --| So we use the Cody-Waite names and derive them from an adaptation --| of the MACHAR routine as given by Cody-Waite in Appendix B. --| --| Initialization Exceptions (none) --| --| Notes --| Not all MIL-HDBK-1804 PDL annotations are --| used in this package due to its simplicity. --| --| Modifications --| Author: Major Terry Courtwright, World Wide Military Command and --| Control Information Systems Joint Program Management Office Ibeta : INTEGER; -- The radix of the floating-point representation It : INTEGER; -- The number of base IBETA digits in the DIS_FLOAT significand Irnd : INTEGER; -- TRUE (1) if floating addition rounds, FALSE (0) if truncates Ngrd : INTEGER; -- Number of guard digits for multiplication Machep : INTEGER; -- The largest negative integer such that -- 1.0 + FLOAT(IBETA) ** MACHEP /= 1.0 -- except that MACHEP is bounded below by -(IT + 3) Negep : INTEGER; -- The largest negative integer such that -- 1.0 -0 FLOAT(IBETA) ** NEGEP /= 1.0 -- except that NEGEP is bounded below by -(IT + 3) Iexp : INTEGER; -- The number of bits (decimal places if IBETA = 10) -- reserved for the representation of the exponent (including -- the bias or sign) of a floating-point number Minexp : INTEGER; -- The largest in magnitude negative integer such that -- FLOAT(IBETA) ** MINEXP is a positive floating-point number Maxexp : INTEGER; -- The largest positive exponent for a finite floating-point number Eps : FLOAT; -- The smallest positive floating-point number such that -- 1.0 + EPS /= 1.0 -- In particular, if IBETA = 2 or IRND = 0, -- EPS = FLOAT(IBETA) ** MACHEP -- Otherwise, EPS = (FLOAT(IBETA) ** MACHEP) / 2 Epsneg : FLOAT; -- A small positive floating-point number such that 1.0-EPSNEG /= 1.0 Xmin : FLOAT; -- The smallest non-vanishing floating-point power of the radix -- In particular, XMIN = FLOAT(IBETA) ** MINEXP Xmax : FLOAT; -- The largest finite floating-point number -- Here the structure of the floating type is defined. -- I have assumed that the exponent is always some integer form. -- The mantissa can vary. -- Most often it will be a fixed type or the same floating type -- depending on the most efficient machine implementation. -- Most efficient implementation may require details of the machine hardware -- In this version the simplest representation is used. -- The mantissa is extracted into a FLOAT and uses the predefined operations. subtype EXPONENT_TYPE is INTEGER; -- should be derived subtype MANTISSA_TYPE is FLOAT; -- range -1.0..1.0; -- A consequence of the rigorous constraints on MANTISSA_TYPE is that -- operations must be very carefully examined to make sure that no number -- greater than one results. -- Actually this limitation is important in constructing algorithms -- which will also run when MANTISSA_TYPE is a fixed point type. -- If we are not using the STANDARD type, we have to define all the -- operations at this point. -- We also need PUT for the type if it is not otherwise available. -- Now we do something strange. -- Since we do not know in the following routines whether the mantissa -- will be carried as a fixed or floating type, we have to make some -- provision for dividing by two. -- We cannot use the literals, since FIXED/2.0 and FLOAT/2 will fail. -- We define a type-dependent factor that will work. Mantissa_Divisor_2 : constant FLOAT := 2.0; Mantissa_Divisor_3 : constant FLOAT := 3.0; -- This will work for the MANTISSA_TYPE defined above. -- The alternative of defining an operation "/" to take care of it -- is too sweeping and would allow unAda-like errors. Mantissa_Half : constant MANTISSA_TYPE := 0.5; -- Subprograms procedure Defloat (X : in FLOAT; L : out EXPONENT_TYPE; E : out MANTISSA_TYPE); procedure Refloat (N : in EXPONENT_TYPE; F : in MANTISSA_TYPE; Z : out FLOAT); -- Since the user may wish to define a floating type by some other name -- CONVERT_TO_FLOAT is used rather than just FLOAT for explicit coersion. function Convert_to_Float (K : INTEGER) return FLOAT; --function CONVERT_TO_FLOAT(N : EXPONENT_TYPE) return FLOAT; function Convert_to_Float (F : MANTISSA_TYPE) return FLOAT; end Floating_Characteristics; -- *************************************************************** -- * * -- * NUMERIC_PRIMITIVES * SPEC -- * * -- *************************************************************** with Floating_Characteristics; use Floating_Characteristics; package Numeric_Primitives is --| Purpose --| This package contains the definitions of several useful constants --| and functions associated with FLOAT numbers. --| --| Initialization Exceptions (none) --| --| Notes --| Due to the simplicity of this package, the MIL-HDBK-1804 PDL --| annotations are not used in the rest of this specification. --| --| Modifications --| Author: Major Terry Courtwright, World Wide Military Command and --| Control Information Systems Joint Program Management Office -- This may seem a little much but is put in this form to allow the -- same form to be used for a generic package. -- If that is not needed, simple litterals could be substituted. Zero : FLOAT; One : FLOAT; Two : FLOAT; Three : FLOAT; Half : FLOAT; -- The following "constants" are effectively deferred to -- the initialization part of the package body. -- This is in order to make it possible to generalize the floating type. -- If that capability is not desired, constants may be included here. PI : FLOAT; One_Over_PI : FLOAT; Two_Over_PI : FLOAT; PI_Over_Two : FLOAT; PI_Over_Three : FLOAT; PI_Over_Four : FLOAT; PI_Over_Six : FLOAT; -- Subprograms function Sign (X, Y : FLOAT) return FLOAT; -- Returns the value of X with the sign of Y. function Max (X, Y : FLOAT) return FLOAT; -- Returns the algebraicly larger of X and Y. function Truncate (X : FLOAT) return FLOAT; -- Returns the floating value of the integer no larger than X. -- AINT(X) function Round (X : FLOAT) return FLOAT; -- Returns the floating value nearest X. -- AINTRND(X) function Ran return FLOAT; -- This uses a portable algorithm and is included at this point. -- Algorithms that presume unique machine hardware information -- should be initiated in FLOATING_CHARACTERISTICS. end Numeric_Primitives; -- *************************************************************** -- * * -- * CORE_FUNCTIONS * SPEC -- * * -- *************************************************************** with Floating_Characteristics; use Floating_Characteristics; package Core_Functions is --| Purpose --| This package contains the definitions of several fundamental --| functions associated with FLOAT numbers. --| --| Initialization Exceptions (none) --| --| Notes --| Due to the simplicity of this package, the MIL-HDBK-1804 PDL --| annotations are not used in the rest of this specification. --| --| Modifications --| Author: Major Terry Courtwright, World Wide Military Command and --| Control Information Systems Joint Program Management Office Exp_Large : FLOAT; Exp_Small : FLOAT; -- Subprograms function SQRT(X : FLOAT) return FLOAT; function CBRT(X : FLOAT) return FLOAT; function LOG(X : FLOAT) return FLOAT; function LOG10(X : FLOAT) return FLOAT; function EXP(X : FLOAT) return FLOAT; function "**"(X, Y : FLOAT) return FLOAT; end Core_Functions; -- *************************************************************** -- * * -- * TRIG_FUNCTIONS * SPEC -- * * -- *************************************************************** package Trig_Functions is --| Purpose --| This package contains the definitions of several trigonometric --| and hypertrigonometic functions associated with FLOAT numbers. --| --| Initialization Exceptions (none) --| --| Notes --| Due to the simplicity of this package, the MIL-HDBK-1804 PDL --| annotations are not used in the rest of this specification. --| --| Modifications --| Author: Major Terry Courtwright, World Wide Military Command and --| Control Information Systems Joint Program Management Office function SIN(X : FLOAT) return FLOAT; function COS(X : FLOAT) return FLOAT; function TAN(X : FLOAT) return FLOAT; function COT(X : FLOAT) return FLOAT; function ASIN(X : FLOAT) return FLOAT; function ACOS(X : FLOAT) return FLOAT; function ATAN(X : FLOAT) return FLOAT; function ATAN2(V, U : FLOAT) return FLOAT; function SINH(X : FLOAT) return FLOAT; function COSH(X : FLOAT) return FLOAT; function TANH(X : FLOAT) return FLOAT; end Trig_Functions; --:::::::::: --out.spc --:::::::::: -- ********************************** -- * * -- * Output_File * SPEC -- * * -- ********************************** package Output_File is --| Purpose --| Output_File implements an abstract data type of an output file. --| Output_File offers an abstraction that can be made more efficient --| by not using Text_IO (and having its associated overhead imposed) --| if possible and also offers the ability to suppress the output, --| which may be desired if a caller is skipping over pages and just --| wants to output to a null device during this process. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version type FILE_TYPE is private; Cannot_Create_Output_File : exception; Write_Error : exception; -- .................................. -- . . -- . Output_File.Already_Exists . SPEC -- . . -- .................................. function Already_Exists ( File_Name : in STRING ) return BOOLEAN; --| Purpose --| Determine if the FILE_TYPE object already exists. --| --| Exceptions (none) --| Notes (none) -- .................................. -- . . -- . Output_File.Delete . SPEC -- . . -- .................................. function Delete ( File_Name : in STRING ) return BOOLEAN; --| Purpose --| Delete the FILE_TYPE object. Return TRUE if successful. --| --| Exceptions (none) --| Notes (none) -- .................................. -- . . -- . Output_File.Create . SPEC -- . . -- .................................. procedure Create ( Id : in out FILE_TYPE; File_Name : in STRING ); --| Purpose --| Create creates a new FILE_TYPE object. --| --| Exceptions --| Cannot_Create_Output_File --| --| Notes (none) -- .................................. -- . . -- . Output_File.Put . SPEC -- . . -- .................................. procedure Put ( Id : in out FILE_TYPE; Item : in CHARACTER ); procedure Put ( Id : in out FILE_TYPE; Item : in STRING ); --| Purpose --| Put writes an Item to the FILE_TYPE object. --| --| Exceptions --| Write_Error --| --| Notes (none) -- .................................. -- . . -- . Output_File.Put_Line . SPEC -- . . -- .................................. procedure Put_Line ( Id : in out FILE_TYPE; Item : in STRING ); --| Purpose --| Put_Line writes an Item to the FILE_TYPE object. The Item is followed --| by a New_Line; --| --| Exceptions --| Write_Error --| --| Notes (none) -- .................................. -- . . -- . Output_File.New_Line . SPEC -- . . -- .................................. procedure New_Line ( ID : in out FILE_TYPE ); --| Purpose --| New_Line writes an end-of-line sequence to the FILE_TYPE object. --| --| Exceptions --| Write_Error --| --| Notes (none) -- .................................. -- . . -- . Output_File.New_Page . SPEC -- . . -- .................................. procedure New_Page ( ID : in out FILE_TYPE ); --| Purpose --| New_Page writes an end-of-page sequence to the FILE_TYPE object. --| --| Exceptions --| Write_Error --| --| Notes (none) -- .................................. -- . . -- . Output_File.Enable_Output . SPEC -- . Output_File.Disable_Output . -- . . -- .................................. procedure Enable_Output ( ID : in out FILE_TYPE ); procedure Disable_Output ( ID : in out FILE_TYPE ); --| Purpose --| Enable_Output and Disable_Output enable and disable the output of --| Items and new lines to the FILE_TYPE object. When created, output --| to a FILE_TYPE object is enabled. --| --| Exceptions (none) --| Notes (none) -- .................................. -- . . -- . Output_File.Close . SPEC -- . . -- .................................. procedure Close ( ID : in out FILE_TYPE ); --| Purpose --| Close closes output to the FILE_TYPE object. --| --| Exceptions (none) --| Notes (none) private -- Output_File type FILE_OBJECT; type FILE_TYPE is access FILE_OBJECT; end Output_File; --:::::::::: --permutat.spc --:::::::::: -- **************************************************** -- * * -- * Permutations_Class * SPEC -- * * -- **************************************************** generic type ITEM_TYPE is private; type INDEX_TYPE is (<>); type LIST_TYPE is array (INDEX_TYPE range <>) of ITEM_TYPE; package Permutations_Class is --| Purpose --| Generate all permutations of a set of ITEM_TYPE objects. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Doug Bryan, Stanford University -- ........................................................ -- . . -- . Permutations_Class.Iterate_Through_Length... . SPEC -- . . -- ........................................................ generic with procedure Process (A_Permutation : LIST_TYPE); procedure Iterate_Through_Length_Factorial_Permutations (Of_Items : LIST_TYPE); --| Purpose --| For an actual parameter for Of_Items of length n, --| n! (n factorial) permutations will be produced. --| --| The procedure permutes the elements in the array ITEMS. --| actually it permutes their indicies and re-arranges the items --| within the list. The procedure does not care of any or all --| of the items in the list are equal (the same). --| --| Exceptions (none) --| Notes (none) end Permutations_Class; --:::::::::: --priqueue.spc --:::::::::: -- ******************************************************** -- * * -- * PRIORITIZED_QUEUE * SPEC -- * * -- ******************************************************** generic type ENQUEUED_OBJECT is limited private; type PRIORITY_VALUE is (<>); with procedure Assign (Target : in out ENQUEUED_OBJECT; Source : in ENQUEUED_OBJECT) is <>; with function "=" (First_Object : in ENQUEUED_OBJECT; Second_Object : in ENQUEUED_OBJECT) return BOOLEAN is <>; with procedure Destroy (Targeted_Object : in out ENQUEUED_OBJECT) is <>; with function "<" (First_Object : in PRIORITY_VALUE; Second_Object : in PRIORITY_VALUE) return BOOLEAN is <>; package Prioritized_Queue is --| Purpose --| Support prioritized queues. Items may be added to removed --| from these queues based on priority, as opposed to first --| arrival. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Bill Wolfe, Clemson University -- ******************************************************* -- This software is part of the Clemson University -- Computer Science Department's Ada Software -- Repository, and is copyrighted (C) 1989 by -- Clemson University. Permission to copy without -- fee all or part of this software is granted, -- provided that the copies are not made or -- distributed for direct commercial advantage, and -- that this copyright notice is not deleted or -- modified. To copy otherwise, or to republish, -- requires a fee and/or specific permission. -- ******************************************************* type PRIORITY_QUEUE is limited private; -- requires O (n) space, where n is the NUMBER_OF_ITEMS in the queue. Requested_Item_Does_Not_Exist_In_This_Priority_Queue : EXCEPTION; No_Items_Currently_Exist_In_This_Empty_Priority_Queue : EXCEPTION; type POINTER_TO_PRIORITY_QUEUE is access PRIORITY_QUEUE; -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.DESTROY . SPEC -- . . -- .......................................................... procedure Destroy (Targeted_Object : in out POINTER_TO_PRIORITY_QUEUE); --| Purpose --| Remove the queue, freeing the space allocated to it. --| --| Exceptions (none) --| --| Notes --| Unlike UNCHECKED_DEALLOCATION, this procedure will properly --| destroy the PRIORITY_QUEUE being pointed to. Works in O (n) --| time, where n is the NUMBER_OF_ITEMS in the PRIORITY_QUEUE --| being pointed to. -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.INSERT_ITEM . SPEC -- . . -- .......................................................... procedure Insert_Item (Queue : in out PRIORITY_QUEUE; Object : in ENQUEUED_OBJECT; Priority : in PRIORITY_VALUE); --| Insert the indicated OBJECT into the QUEUE at the given PRIORITY. --| --| Exceptions (none) --| --| Notes --| The QUEUE can safely handle multiple instances of a given --| (OBJECT, PRIORITY) pair. Works in O (log n) time, where n --| is the NUMBER_OF_ITEMS in the updated QUEUE. --| A series of consecutive initializing insertions uses O (n) time, --| where n is the number of insertions. -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.REMOVE_HIGHEST_PRIORITY_OBJECT . SPEC -- . . -- .......................................................... procedure Remove_Highest_Priority_Object (Highest_Priority_Object : in out ENQUEUED_OBJECT; Queue : in out PRIORITY_QUEUE); --| Purpose --| Remove the highest priority object. If there are several objects --| of the same highest priority, the first object entered will be --| removed. --| --| Exceptions --| No_Items_Currently_Exist_In_This_Empty_Priority_Queue --| --| Notes --| Works in O (log n) time, where n is the NUMBER_OF_ITEMS --| originally in the QUEUE. Raises --| No_Items_Currently_Exist_In_This_Empty_Priority_Queue --| if the QUEUE is EMPTY. -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.REMOVE_HIGHEST_PRIORITY_OBJECT . SPEC -- . . -- .......................................................... procedure Remove_Highest_Priority_Object (Highest_Priority_Object : in out ENQUEUED_OBJECT; Priority_of_the_Object : out PRIORITY_VALUE; Queue : in out PRIORITY_QUEUE); --| Purpose --| Remove the highest priority object in a queue, returning both --| the object and its priority. --| --| Exceptions --| No_Items_Currently_Exist_In_This_Empty_Priority_Queue --| --| Notes --| Works in O (log n) time, where n is the NUMBER_OF_ITEMS --| originally in the QUEUE. --| Raises No_Items_Currently_Exist_In_This_Empty_Priority_Queue --| if the QUEUE is EMPTY. -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.DELETE_ITEM . SPEC -- . . -- .......................................................... procedure Delete_Item (Queue : in out PRIORITY_QUEUE; Object : in ENQUEUED_OBJECT; Priority : in PRIORITY_VALUE); --| Purpose --| Delete an item in the queue given the item and its priority. --| --| Exceptions --| Requested_Item_Does_Not_Exist_In_This_Priority_Queue --| No_Items_Currently_Exist_In_This_Empty_Priority_Queue --| --| Notes --| Works in O (n) time, where n is the NUMBER_OF_ITEMS originally --| in the QUEUE. --| --| If multiple occurrences of the specified OBJECT and PRIORITY --| exist, the first such occurrence found will be deleted, and --| all others will be left undisturbed. --| PURGE_ITEM should be used if you wish to eliminate all such --| occurrences. --| --| If no occurrences of the specified OBJECT and PRIORITY exist, --| and the queue is not EMPTY, raises --| Requested_Item_Does_Not_Exist_In_This_Priority_Queue. --| --| If the QUEUE is EMPTY, raises --| No_Items_Currently_Exist_In_This_Empty_Priority_Queue. -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.PURGE_ITEM . SPEC -- . . -- .......................................................... procedure Purge_Item (Queue : in out PRIORITY_QUEUE; Object : in ENQUEUED_OBJECT); --| Purpose --| Remove all instances of an OBJECT regardless of its priority. --| --| Exceptions (none) --| --| Notes --| Works in O (n) time, where n is the NUMBER_OF_ITEMS originally --| in the QUEUE. --| --| Will terminate normally, even if the QUEUE was already EMPTY... -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.PURGE_ITEM . SPEC -- . . -- .......................................................... procedure Purge_Item (Queue : in out PRIORITY_QUEUE; Object : in ENQUEUED_OBJECT; Priority : in PRIORITY_VALUE); --| Purpose --| Remove all instances of an OBJECT at a given PRIORITY. --| --| Exceptions (none) --| --| Notes --| Works in O (n) time, where n is the NUMBER_OF_ITEMS originally --| in the QUEUE. --| --| Will terminate normally, even if the QUEUE was already EMPTY... -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.PURGE_PRIORITY . SPEC -- . . -- .......................................................... procedure Purge_Priority (Queue : in out PRIORITY_QUEUE; Priority : in PRIORITY_VALUE); --| Purpose --| Removes all objects of a given PRIORITY. --| --| Exceptions (none) --| --| Notes --| Works in O (n) time, where n is the NUMBER_OF_ITEMS originally --| in the QUEUE. --| --| Will terminate normally, even if the QUEUE was already EMPTY... -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.PURGE_PRIORITY_RANGE . SPEC -- . . -- .......................................................... procedure Purge_Priority_Range (Queue : in out PRIORITY_QUEUE; From_Priority : in PRIORITY_VALUE; To_Priority : in PRIORITY_VALUE); --| Purpose --| Remove all objects with priorities between FROM_PRIORITY and --| TO_PRIORITY, inclusive. --| --| Exceptions (none) --| --| Notes --| Works in O (n) time, where n is the NUMBER_OF_ITEMS originally --| in the QUEUE. --| --| Will terminate normally, even if the QUEUE was already EMPTY... -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.MERGE . SPEC -- . . -- .......................................................... procedure Merge (Target_Queue : in out PRIORITY_QUEUE; Source_Queue : in PRIORITY_QUEUE); --| Purpose --| Merge two queues. The objects which were in the SOURCE_QUEUE --| are merged into the TARGET_QUEUE; the SOURCE_QUEUE --| is left EMPTY. --| --| Exceptions (none) --| --| Notes --| Works in O (log n) time, where n is the NUMBER_OF_ITEMS --| in the newly merged queue. -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.CHANGE_PRIORITY . SPEC -- . . -- .......................................................... procedure Change_Priority (Queue : in out PRIORITY_QUEUE; Object : in ENQUEUED_OBJECT; Old_Priority : in PRIORITY_VALUE; New_Priority : in PRIORITY_VALUE); --| Purpose --| Change the priority of an object in a queue. --| --| Exceptions --| Requested_Item_Does_Not_Exist_In_This_Priority_Queue --| No_Items_Currently_Exist_In_This_Empty_Priority_Queue --| --| Notes --| Works in O (n) time, where n is the NUMBER_OF_ITEMS in the QUEUE. --| --| If multiple occurrences of the specified OBJECT and OLD_PRIORITY --| exist in the QUEUE, the first such occurrence found will be --| modified, and all others will be left undisturbed. --| --| If no occurrences of the specified OBJECT and OLD_PRIORITY exist --| in the QUEUE, and the QUEUE is not EMPTY, raises --| Requested_Item_Does_Not_Exist_In_This_Priority_Queue. --| --| If the QUEUE is EMPTY, raises --| No_Items_Currently_Exist_In_This_Empty_Priority_Queue. -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.EMPTY . SPEC -- . . -- .......................................................... function Empty (Queue : in PRIORITY_QUEUE) return BOOLEAN; --| Purpose --| Determine if a queue is empty. --| --| Exceptions (none) --| --| Notes --| Works in O (1) time. -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.NUMBER_OF_ITEMS . SPEC -- . . -- .......................................................... function Number_of_Items (Queue : in PRIORITY_QUEUE) return NATURAL; --| Purpose --| Determines the number of items in a queue. --| --| Exceptions (none) --| --| Notes --| Works in O (n) time, where n is the NUMBER_OF_ITEMS in the QUEUE. -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.ASSIGN . SPEC -- . . -- .......................................................... procedure Assign (Target_Object : in out PRIORITY_QUEUE; Source_Object : in PRIORITY_QUEUE); --| Purpose --| Assign one queue to another, replacing the TARGET_OBJECT. --| --| Exceptions (none) --| --| Notes --| Works in O (n) time, where n is the maximum of the --| NUMBER_OF_ITEMS to be destroyed in the TARGET_OBJECT --| and the NUMBER_OF_ITEMS in the SOURCE_OBJECT. -- .......................................................... -- . . -- . PRIORITIZED_QUEUE.DESTROY . SPEC -- . . -- .......................................................... procedure Destroy (Targeted_Object : in out PRIORITY_QUEUE); --| Purpose --| Destroy a queue, freeing its contents. --| --| Exceptions (none) --| --| Notes --| Works in O (n) time, where n is the NUMBER_OF_ITEMS in the QUEUE. private type PRIORITY_QUEUE_NODE; type PRIORITY_QUEUE is access PRIORITY_QUEUE_NODE; end PRIORITIZED_QUEUE; --:::::::::: --qsort.spc --:::::::::: -- .................................................... -- . . -- . QSORT . SPEC -- . . -- .................................................... generic type ITEM is private; type INDEX is (<>); type ROW is array (INDEX range <>) of ITEM; with function "<" (X, Y : ITEM) return BOOLEAN is <>; procedure Qsort (A : in out ROW); --| Purpose --| Sort the one-dimensional array A using the Quick Sort --| algorithm. --| --| Exceptions (none) --| Notes (none) --| --| Modifications --| Author: John Anderson, TI --:::::::::: --random.spc --:::::::::: -- ******************************************************** -- * * -- * RANDOM * SPEC -- * * -- ******************************************************** package Random is --| Purpose --| Random.Number returns a pseudo-random number in 0.0 .. 1.0. --| --| Initialization Exceptions (none) --| Notes --| Uses 16-bit integers, so should be quite portable. --| Not all MIL-HDBK-1804 PDL annotations are --| used in this package due to its simplicity. --| --| Modifications --| Original Work: Bill Whitaker --| Later Mods by: Richard Conn, Ron Bell -- ...................................................... -- . . -- . RANDOM.NUMBER . SPEC -- . . -- ...................................................... function Number return FLOAT; end Random; --:::::::::: --scanners.spc --:::::::::: -- ************************************************** -- * * -- * Scanners * SPEC -- * * -- ************************************************** package Scanners is --| Purpose --| This package is used to break strings into tokens in a --| very simple but efficient manner. For maximum efficiency, --| the scanner type is not private so that it can be used --| directly. The following conventions are adopted to allow --| the Ada string handling primitives to be used to maximum --| advantage: --| --| 1. Strings are never copied. The scanner type contains --| First and Last components so that slices may be used --| to obtain the desired tokens (substrings). --| --| 2. The scanner type does not include a copy of the --| string being scanned, also to avoid copying strings. --| --| 3. The Length component of a scanner is always set to the --| length of the item scanned. If it is zero it means --| that no such item was found, either because it wasn't --| there or because the scanner is exhausted. The is_Empty --| operation may be used to determint if a scanner is --| exhausted (usually before attempting to scan something). --| --| 4. All operations have well defined behavior for any --| consistent input. There are no exceptions declared in --| this package or raised directly by the operations in --| the package. --| --| Initialization Exceptions (none) --| --| Notes --| Not all MIL-HDBK-1804 PDL annotations are --| used in this package due to its simplicity. --| No exceptions are raised by this package. --| --| Modifications --| Author: Bill Toscano and Michael Gordon, Intermetrics -- Types: type SCANNER_TYPE is record Index : NATURAL; -- Index of next char to be scanned Max_Index : NATURAL; -- Index of last scannable char First : NATURAL; -- Index of 1st char of the result of a scan Last : NATURAL; -- Index of last char of the result of a scan Length : NATURAL; -- Length of the item scanned end record; -- Constructors: -- ............................................... -- . . -- . Scanners.Start_Scanner . SPEC -- . . -- ............................................... procedure Start_Scanner ( Scanner : in out SCANNER_TYPE; S : in STRING; Last : in NATURAL); --| Purpose --| Initialize Scanner for scanning S from S'FIRST to Last. --| S and Last are typically obtained by calling --| Text_IO.Get_Line. -- ............................................... -- . . -- . Scanners.Is_Empty . SPEC -- . . -- ............................................... function Is_Empty (Scanner: in SCANNER_TYPE) return BOOLEAN; pragma inline(is_Empty); --| Purpose --| Return True iff Scanner.Index > Scanner.Max_Index. --| Return TRUE iff there are more characters to scan. -- ............................................... -- . . -- . Scanners.Is_Alpha . SPEC -- . . -- ............................................... function Is_Alpha (Scanner : in SCANNER_TYPE; S : in STRING) return BOOLEAN; pragma inline(is_Alpha); --| Purpose --| Return True iff S(Scanner.Index) is an alphabetic character. -- ............................................... -- . . -- . Scanners.Is_Alpha . SPEC -- . . -- ............................................... function Is_Digit (Scanner : in SCANNER_TYPE; S : in string) return BOOLEAN; pragma inline(is_Digit); --| Purpose --| Return True iff S(Scanner.Index) is a decimal digit. -- ............................................... -- . . -- . Scanners.Is_Sign . SPEC -- . . -- ............................................... function Is_Sign (Scanner : in SCANNER_TYPE; S : in STRING) return BOOLEAN; pragma inline(is_Sign); --| Purpose --| Return True iff S(Scanner.Index) is '+' or '-' -- ............................................... -- . . -- . Scanners.Is_Digit_or_Sign . SPEC -- . . -- ............................................... function Is_Digit_or_Sign (Scanner : in SCANNER_TYPE; S : in string) return BOOLEAN; pragma inline(is_Digit_or_Sign); --| Purpose --| Return True iff S(Scanner.Index) is '+', '-', or a decimal digit. -- ............................................... -- . . -- . Scanners.Skip_Blanks . SPEC -- . . -- ............................................... procedure Skip_Blanks (Scanner : in out SCANNER_TYPE; S : in STRING); --| Purpose --| Increment Scanner.Index until S(Scanner.Index) is --| neither a blank nor a tab character, or until it is --| greater than Scanner.Max_Index. -- ............................................... -- . . -- . Scanners.Trim_Blanks . SPEC -- . . -- ............................................... procedure Trim_Blanks (Scanner : in out SCANNER_TYPE; S : in STRING); --| Purpose --| Adjust Scanner.First and Scanner.Last such that --| S(Scanner.First..Scanner.Last) contains neither leading --| nor trailing blanks or tabs. Scanner.Length is adjusted --| accordingly. This is useful to remove blanks after a --| call to Scan_Delimited, Scan_Quoted, Scan_Until, etc. -- ............................................... -- . . -- . Scanners.Scan_Until . SPEC -- . . -- ............................................... procedure Scan_Until (Scanner : in out SCANNER_TYPE; S : in STRING; C : in CHARACTER); --| Purpose --| Scan in string S starting at Scanner.Index until the --| character C is encountered or the string ends. On --| return, if Scanner.Length > 0 then --| S(Scanner.First..Scanner.Last) contains the characters that --| appeared before C and Scanner(Index) = C. If C was --| not found, then the scanner is not affected except to --| set Scanner.Length to 0. -- ............................................... -- . . -- . Scanners.Scan_Word . SPEC -- . . -- ............................................... procedure Scan_Word (Scanner : in out SCANNER_TYPE; S : in STRING); --| Purpose --| Scan in string S for a sequence of non-blank characters, --| starting at Scanner.Index. On return, if --| Scanner.Length > 0 then S(Scanner.First..Scanner.Last) --| is a word and Scanner.Index is just past the end of the --| word (Scanner.Last+1), ready to scan the next item. -- ............................................... -- . . -- . Scanners.Scan_Number . SPEC -- . . -- ............................................... procedure Scan_Number (Scanner : in out SCANNER_TYPE; S : in STRING); --| Purpose --| Scan in string S for a sequence of numeric characters, --| optionally preceeded by a sign (+/-), starting at --| Scanner.Index. On return, if Scanner.Length > 0 then --| S(Scanner.First..Scanner.Last) is a number and --| Scanner.Index is just past the end of the number --| (Scanner.Last+1), ready to scan the next item. -- ............................................... -- . . -- . Scanners.Scan_Delimited . SPEC -- . . -- ............................................... procedure Scan_Delimited (Scanner : in out SCANNER_TYPE; S : in STRING); --| Purpose --| The character S(Scanner.Index) is considered a "quote". --| Scanner.First is set to the Scanner.Index+1, and --| Scanner.Index is incremented until another "quote" --| is encountered or the end of the string is reached. --| On return, Scanner.Last is the index of the closing --| "quote" or the last character in S if no closing "quote" --| was found. -- ............................................... -- . . -- . Scanners.Scan_Quoted . SPEC -- . . -- ............................................... procedure Scan_Quoted (Scanner : in out SCANNER_TYPE; S : in out STRING); --| Purpose --| The character S(Scanner.Index) is considered a "quote". --| The string S is scanned for a closing "quote". During --| the scan, two quotes in a row are replaced by a single --| quote. On return, Scanner.First is the first character --| of the quoted string, and Scanner.Last is the last --| character. (The outermost quotes are not included.) --| Scanner.Index is the first character after the --| closing quote, Scanner.Length is the number of characters --| in the quoted string. Note that the string being scanned --| (S) is modified by this routine (to remove the extra quotes, --| if any). end Scanners; --:::::::::: --search.spc --:::::::::: -- ***************************************************** -- * * -- * SEARCH_UTILITIES * SPEC -- * * -- ***************************************************** with System; generic type COMPONENT_TYPE is limited private; -- type of component to search for type INDEX_TYPE is (<>); -- type of array index type ARRAY_TYPE is array (INDEX_TYPE range <>) of COMPONENT_TYPE; with function "<"(Left, Right : in COMPONENT_TYPE) return BOOLEAN is <>; with function "="(Left, Right : in COMPONENT_TYPE) return BOOLEAN is <>; package Search_Utilities is --| Purpose --| Search_Utilities is a generic searching package. The Search subprograms --| will search a one dimensional array of any data type --| indexed by discrete type components. --| --| Note that the component type of the array is not restricted to simple --| types. An array of records or allocators can be searched. If the --| component type is a record or allocator, then the generic formal --| subprogram parameter "<" below must be specified as a selector --| function. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Geoff Mendal, Stanford University type DATA_ORDER_TYPE is (ORDERED, NOT_ORDERED); -- This type should be used to specify how the data is -- ordered. The default is Not_Ordered. However, significant CPU time -- can be saved if the data is ordered and the default, Not_Ordered, -- is overridden. -- -- If the data are ordered, then if two or more components in the array -- can match the search component provided, then the component location -- returned by Search should be thought of as an arbitrary selection -- from amongst those possible match-components. -- -- If the data are not ordered, then if two or more components in the -- array can match the search component provided, then the component -- location returned by Search will be the one closest to -- Search_Array'FIRST. type PERFORMANCE_INSTRUMENTATION_TYPE is range -1 .. System.Max_Int; -- This type declaration should be used to specify the -- instrumentation analysis data that can be returned by the -- Search procedure below. -1 is only returned if an overflow in -- calculations has occurred. The Search subprograms will not terminate -- if an overflow in instrumentation analysis data calculations has -- occurred. -- .................................................... -- . . -- . SEARCH_UTILITIES.VERSION . SPEC -- . . -- .................................................... function Version return STRING; --| Purpose --| Returns the version number of this package. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . SEARCH_UTILITIES.SEARCH . SPEC -- . . -- .................................................... procedure Search ( Component : in COMPONENT_TYPE; Search_Array : in ARRAY_TYPE; Location_Found : out INDEX_TYPE; Component_Found : out BOOLEAN; Number_of_Comparisons : out PERFORMANCE_INSTRUMENTATION_TYPE; Order_Strategy : in DATA_ORDER_TYPE := NOT_ORDERED; No_Match_Index : in INDEX_TYPE := INDEX_TYPE'LAST); --| Purpose --| This procedure will search a one dimensional array of --| components. It can search an ordered or unordered array. If --| an ordered array is specified, it defaults to an ascending --| order (which can be overridden by the user). The array components --| must only support equality, inequality, and assignment (private --| types). The array indices can be of any discrete type. The number --| of comparisons can also be returned. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . SEARCH_UTILITIES.SEARCH . SPEC -- . . -- .................................................... procedure Search ( Component : in COMPONENT_TYPE; Search_Array : in ARRAY_TYPE; Location_Found : out INDEX_TYPE; Component_Found : out BOOLEAN; Order_Strategy : in DATA_ORDER_TYPE := NOT_ORDERED; No_Match_Index : in INDEX_TYPE := INDEX_TYPE'LAST); --| Purpose --| This overloading of procedure Search should be used when --| no instrumentation analysis data are required. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . SEARCH_UTILITIES.SEARCH . SPEC -- . . -- .................................................... function Search ( Component : in COMPONENT_TYPE; Search_Array : in ARRAY_TYPE; Order_Strategy : in DATA_ORDER_TYPE := NOT_ORDERED) return BOOLEAN; --| Purpose --| This overloading of function Search should be used when --| the user only wants to know if the component exists or not. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . SEARCH_UTILITIES.SEARCH . SPEC -- . . -- .................................................... function Search ( Component : in COMPONENT_TYPE; Search_Array : in ARRAY_TYPE; Order_Strategy : in DATA_ORDER_TYPE := NOT_ORDERED; No_Match_Index : in INDEX_TYPE := INDEX_TYPE'LAST) return INDEX_TYPE; --| Purpose --| This overloading of function Search should be used when --| the component is definitely known to exist and only the location --| is required. (Note that No_Match_Index may be used to return a --| no match index value... but this won't work in all cases.) --| --| Exceptions (none) --| Notes (none) end Search_Utilities; --:::::::::: --slist.spc --:::::::::: -- ***************************************************************** -- * * -- * SINGLY_LINKED_LIST * SPEC -- * * -- ***************************************************************** generic type LIST_ELEMENT is private; package Singly_Linked_List is --| Purpose --| This package provides an abstraction for a singly linked list. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Richard Conn -- Types type LIST_TYPE is limited private; -- Exceptions End_Error : exception; -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.EMPTY . SPEC -- . . -- ............................................................. function Empty (List : LIST_TYPE) return BOOLEAN; --| Purpose --| Indicates whether the list contains any elements. --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.NULL_NODE . SPEC -- . . -- ............................................................. function Null_Node (List : LIST_TYPE) return BOOLEAN; --| Purpose --| Indicates whether the "current pointer" references an element --| in the list. --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.HEAD_NODE . SPEC -- . . -- ............................................................. function Head_Node (List : LIST_TYPE) return BOOLEAN; --| Purpose --| Indicates whether the "current pointer" references the head --| of the list. --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.TAIL_NODE . SPEC -- . . -- ............................................................. function Tail_Node (List : LIST_TYPE) return BOOLEAN; --| Purpose --| Indicates whether the "current pointer" references the tail --| of the list. --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.CURRENT_ELEMENT . SPEC -- . . -- ............................................................. function Current_Element (List : LIST_TYPE) return LIST_ELEMENT; --| Purpose --| Returns the value of the element referenced by the "current pointer". --| Raises End_Error if Null_Node(List) = True. --| --| Exceptions --| End_Error --| --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.FIRST . SPEC -- . . -- ............................................................. procedure First (List : in out LIST_TYPE); --| Purpose --| Positions the "current pointer" at the head of the list --| (even if the list is empty). --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.NEXT . SPEC -- . . -- ............................................................. procedure Next (List : in out LIST_TYPE); --| Purpose --| Positions the "current pointer" at the next element in the list. --| After the last element in the list, Null_Node(List) becomes True. --| Raises End_Error if Null_Node(List) = True. --| --| Exceptions --| End_Error --| --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.INSERT_AFTER . SPEC -- . . -- ............................................................. procedure Insert_After (List : in out LIST_TYPE; Element : LIST_ELEMENT); --| Purpose --| Inserts an element after the "current pointer". --| If Null_Node(List) = True the element is appended after --| the tail element. --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.INSERT_BEFORE . SPEC -- . . -- ............................................................. procedure Insert_Before (List : in out LIST_TYPE; Element : LIST_ELEMENT); --| Purpose --| Inserts an element before the "current pointer". --| If Null_Node(List) = True the element is prepended before --| the head element. --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.DELETE_ELEMENT . SPEC -- . . -- ............................................................. procedure Delete_Element (List : in out LIST_TYPE); --| Purpose --| Deletes the element referenced by the "current pointer" from the list. --| Upon deletion, the "current pointer" references the element after the --| deleted element. --| Raises End_Error if Null_Node(List) = True. --| --| Exceptions --| End_Error --| --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.MODIFY . SPEC -- . . -- ............................................................. generic with procedure Transformation (Element : in out LIST_ELEMENT); procedure Modify (List : LIST_TYPE); --| Purpose --| Permits modification of the element referenced by the "current pointer" --| where the modification doesn't require external values (e.g. --| incrementing a field of the element). --| Raises End_Error if Null_Node(List) = True. --| --| Exceptions --| End_Error --| --| Notes (none) -- ............................................................. -- . . -- . SINGLY_LINKED_LIST.UPDATE . SPEC -- . . -- ............................................................. generic type UPDATE_INFORMATION is private; with procedure Transformation (Element : in out LIST_ELEMENT; Information : UPDATE_INFORMATION); procedure Update (List : LIST_TYPE; Information : UPDATE_INFORMATION); --| Purpose --| Permits modification of the element referenced by the "current pointer" --| where the modification requires external values (e.g. assigning a value --| to a field of the element). --| Raises End_Error if Null_Node(List) = True. --| --| Exceptions --| End_Error --| --| Notes (none) -- Pragmas pragma Inline (Empty, Null_Node, Head_Node, Tail_Node, Current_Element); pragma Inline (Modify, Update); private type NODE; type NODE_ACCESS is access NODE; type NODE is record Element : LIST_ELEMENT; Next : NODE_ACCESS; end record; type LIST_TYPE is record Head : NODE_ACCESS; Tail : NODE_ACCESS; Previous : NODE_ACCESS; Current : NODE_ACCESS; end record; end Singly_Linked_List; --:::::::::: --sort.spc --:::::::::: -- ***************************************************** -- * * -- * SORT_UTILITIES * SPEC -- * * -- ***************************************************** with System; -- predefined package SYSTEM generic type COMPONENT_TYPE is private; -- type of the data components type INDEX_TYPE is (<>); -- type of array index type ARRAY_TYPE is array (INDEX_TYPE range <>) of COMPONENT_TYPE; with function "<" (Left,Right : in COMPONENT_TYPE) return BOOLEAN is <>; with function Equal (Left,Right : in COMPONENT_TYPE) return BOOLEAN is "="; package Sort_Utilities is --| Purpose --| Sort_Utilities is a generic sorting package. The Sort subprograms --| will sort a one dimensional array of any component type that supports --| assignment, equality, and inequality (private types) indexed by --| discrete type components. The default linear order is ascending order --| but may be overridden by the user. The default sort algorithm, --| Quicksort (non-recursive), may also be overridden. --| --| Note that the component type can be a record type. The Sort subprograms --| are not restricted to simple data types. If records are to be sorted, --| then the formal generic subprogram parameter "<" must be --| specified with by a linear order, e.g., a function provided --| as an actual generic subprogram parameter at instantiation. --| --| Note that the component type can be an access type (which can --| point to other objects, improving sort efficiency). If access types --| are to be sorted, then the formal generic subprogram parameter "<" --| must be specified by a linear order (see example #3 below). --| Since access types can be sorted, the Sort routine below can be --| used to sort limited types and unconstrained types (designated by --| an access type). --| --| For data in which equality does not truly apply (i.e., real types) --| one can use the Equal function to specify an equality operation. --| Hence, one can decide that two numbers are "close enough" to be --| equal (see example #4 below). --| --| The number of comparisons and exchanges made to sort the array --| can be returned. These numbers should give some indication on how --| much work was actually performed by the sorting algorithms. These --| numbers can also be used to compare the relative efficiency --| of the sorting algorithms. --| --| This package can be used to sort data on external devices. The user --| should use this package to sort a subset of the external data, then --| use a merge operation on all sorted subsets. For example, if the --| system can only hold 1000 components in RAM, but you need to sort --| 3000 components, bring in components #1-1000 and sort them using this --| routine, and then write them to a file. Next do the same with --| components #1001-2000, and finally with components #2001-3000. Now --| merge the three sorted files using a merge package. --| --| One of the Sort subprograms is a function which can be used to sort --| an array and test it against another in an inline expression. This --| can be useful when comparing the contents of two arrays which may be --| equal, but not at the identical indices. This will be most useful for --| comparing the equality of sets implemented as arrays (see example #5 --| below). --| --| Other Sort subprograms allow the user to maintain the original state --| of the array by returning a new array that is sorted. These subprograms --| will be useful in cases where sorting is required, but the original --| (unsorted) data must be preserved. --| --| Design of this package has been documented in the IEEE Computer --| Society Second International Conference on Ada Applications and --| Environments proceedings. Contact the IEEE or the author for a copy --| of the paper. This paper is forthcoming in a special issue of IEEE --| Software also. --| --| Initialization Exceptions (none) --| --| Notes --| See the explanation below for details on the different --| sort algorithms available and their respective merits. --| There are also examples at the end of this specification --| on the use of this package. --| --| Modifications --| Author: Goeff Mendal, Stanford University type SORT_ALGORITHM_TYPE is (Quicksort, Recursive_Quicksort, Bsort, Bubble_Sort, Bubble_Sort_with_Quick_Exit, Selection_Sort, Heapsort, Insertion_Sort, Merge_Sort); -- Users can specify the type of sorting algorithm they want by -- specifying an enumeration literal from the type above. The default -- algorithm, Quicksort (non-recursive), generally performs best. -- -- One note about stability of the algorithms: only the Bubble Sorts -- and Insertion Sort are stable algorithms. Thus, they are the -- only algorithms that preserve the ordering of equal components -- without use of a selector function. In all cases, a selector -- function may be specified to introduce stability into the -- sorting algorithms (see example #3 below). -- -- Quicksort: O(NlogN). Is most efficient when used with large, unsorted -- arrays. Uses an explicit stack to maintain state and -- partitions. Instable. This is the default algorithm. -- Recursive_Quicksort: O(NlogN). Is most efficient when used with large, -- unsorted arrays. Recursive nature may introduce significant -- memory overhead for very large arrays. Instable. -- Bsort: O(NlogN). Is most efficient when used with large arrays -- that are already sorted, partially sorted, or sorted in -- reverse. Recursive. Instable. -- Bubble_Sort: O(N**2). Is most efficient when used with small -- arrays that are almost already sorted. Non-recursive. -- Brute force. Low memory requirements. Stable. -- Bubble_Sort_with_Quick_Exit: O(N**2). Is most efficient when -- used with small arrays that are almost already sorted. -- Non-recursive. Same as bubble sort above except brute -- force is limited. Stable. -- Selection_Sort: O(N**2). Is most efficient when used with -- small arrays in which the Component_Type is a -- record type. Non-recursive. Brute force. Instable. -- Heapsort: O(NlogN). Is most efficient when used with -- large, unsorted arrays. Non-recursive. Very low -- memory requirements. Instable. -- Insertion_Sort: O(N**2). Is most efficient when used with -- small arrays that are almost already sorted. Non- -- recursive. Brute force. Stable. -- Merge_Sort: O(NlogN). Is most efficient when used with medium-large -- arrays. Non-recursive. Instable. Uses an auxiliary array -- to perform merging. type PERFORMANCE_INSTRUMENTATION_TYPE is range -1 .. SYSTEM.MAX_INT; -- This type declaration should be used to specify the -- instrumentation analysis results that can be returned by the Sort -- subprograms below. -1 is only returned if an overflow in calculations -- has occurred. The Sort subprograms will still sort the array if an -- overflow in instrumentation analysis data calculations -- occurs. Sort_Arrays_Length_Mismatch : exception; -- This exception is raised during execution of the Sort -- subprograms which take two arrays as parameters. These two arrays -- must be of the same length. -- ................................................... -- . . -- . SORT_UTILITIES.VERSION . SPEC -- . . -- ................................................... function Version return STRING; --| Purpose --| Returns the version number of this package. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . SORT_UTILITIES.SORT . SPEC -- . . -- ................................................... procedure Sort ( Sort_Array : in out ARRAY_TYPE; Number_of_Comparisons, Number_of_Exchanges : out PERFORMANCE_INSTRUMENTATION_TYPE; Sort_Algorithm : in SORT_ALGORITHM_TYPE := Quicksort); --| Purpose --| The following procedure will sort a one dimensional array of --| components. It can sort in ascending/descending order or any --| user-defined order. It can sort components of any type that --| support equality, inequality, and assignment (private types). --| The array indices can be of any discrete type. The number of --| comparisons and exchanges can also be returned. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . SORT_UTILITIES.SORT . SPEC -- . . -- ................................................... procedure Sort ( Sort_Array : in out ARRAY_TYPE; Sort_Algorithm : in SORT_ALGORITHM_TYPE := Quicksort); --| Purpose --| This overloading of procedure Sort should be specified --| when no instrumentation analysis data are required. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . SORT_UTILITIES.SORT . SPEC -- . . -- ................................................... procedure Sort ( Unsorted_Array : in ARRAY_TYPE; Sorted_Array : out ARRAY_TYPE; Number_of_Comparisons, Number_of_Exchanges : out PERFORMANCE_INSTRUMENTATION_TYPE; Sort_Algorithm : in SORT_ALGORITHM_TYPE := Quicksort); --| Purpose --| The following overloading of procedure Sort should be used when --| the original data must be preserved and instrumentation analysis --| results are required. --| --| Exceptions --| Sort_Arrays_Length_Mismatch is raised if Unsorted_Array --| and Sorted_Array are not --| the same length --| --| Notes (none) -- ................................................... -- . . -- . SORT_UTILITIES.SORT . SPEC -- . . -- ................................................... procedure Sort ( Unsorted_Array : in ARRAY_TYPE; Sorted_Array : out ARRAY_TYPE; Sort_Algorithm : in SORT_ALGORITHM_TYPE := Quicksort); --| Purpose --| The following overloading of procedure Sort should be used when --| the original data must be preserved and no instrumentation analysis --| results are required. --| --| Exceptions --| Sort_Arrays_Length_Mismatch is raised if Unsorted_Array --| and Sorted_Array are not --| the same length --| --| Notes (none) -- ................................................... -- . . -- . SORT_UTILITIES.SORT . SPEC -- . . -- ................................................... function Sort ( Sort_Array : in ARRAY_TYPE; Sort_Algorithm : in SORT_ALGORITHM_TYPE := Quicksort) return Array_Type; --| Purpose --| This overloading of function Sort should be used when --| sorting is required in an inline expression. end Sort_Utilities; --:::::::::: --stringer.spc --:::::::::: -- ***************************************************************** -- * * -- * STRING_MANIPULATOR * SPEC -- * * -- ***************************************************************** package String_Manipulator is --| Purpose --| STRING_MANIPULATOR provides a few routines --| for storing string values into different --| sizes of strings. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Richard Conn -- Exceptions STRING_OVERFLOW : exception; -- raised by GUARDED_LOAD -- ............................................................. -- . . -- . STRING_MANIPULATOR.LOAD . SPEC -- . . -- ............................................................. procedure Load (From : in STRING; To : out STRING; Fill_Character : in CHARACTER := ' '); --| Purpose --| LOAD places the string FROM into the first part of the --| string TO, filling the rest with FILL_CHARACTER; if the string --| FROM is longer than the string TO, the string FROM is truncated --| into TO without warning --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . STRING_MANIPULATOR.LOAD . SPEC -- . . -- ............................................................. procedure Load (From : in STRING; To : out STRING; Last : out NATURAL; Fill_Character : in CHARACTER := ' '); --| Purpose --| LOAD places the string FROM into the first part of the --| string TO, filling the rest with FILL_CHARACTER; if the string --| FROM is longer than the string TO, the string FROM is truncated --| into TO without warning --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . STRING_MANIPULATOR.GUARDED_LOAD . SPEC -- . . -- ............................................................. procedure Guarded_Load (From : in STRING; To : out STRING; Fill_Character : in CHARACTER := ' '); --| Purpose --| GUARDED_LOAD places the string FROM into the first part of the --| string TO, filling the rest with FILL_CHARACTER; if the string --| FROM is longer than the string TO, the exception STRING_OVERFLOW is --| raised --| --| Exceptions --| STRING_OVERFLOW --| --| Notes (none) -- ............................................................. -- . . -- . STRING_MANIPULATOR.GUARDED_LOAD . SPEC -- . . -- ............................................................. procedure Guarded_Load (From : in STRING; To : out STRING; Last : out NATURAL; Fill_Character : in CHARACTER := ' '); --| Purpose --| GUARDED_LOAD places the string FROM into the first part of the --| string TO, filling the rest with FILL_CHARACTER; if the string --| FROM is longer than the string TO, the exception STRING_OVERFLOW is --| raised --| --| Exceptions --| STRING_OVERFLOW --| --| Notes (none) -- ............................................................. -- . . -- . STRING_MANIPULATOR.FILL . SPEC -- . . -- ............................................................. procedure Fill (What : out STRING; With_Item : in CHARACTER := ' '); --| Purpose --| FILL fills the string WHAT with the indicated WITH_ITEM --| --| Exceptions (none) --| Notes (none) -- ............................................................. -- . . -- . STRING_MANIPULATOR.IS_FILLED . SPEC -- . . -- ............................................................. function Is_Filled (What : in STRING; With_Item : in CHARACTER := ' ') return BOOLEAN; --| Purpose --| IS_FILLED returns TRUE if the string WHAT contains only the --| character WITH_ITEM; IS_FILLED returns FALSE otherwise --| --| Exceptions (none) --| Notes (none) end String_Manipulator; --:::::::::: --testlog.spc --:::::::::: -- ************************************************** -- * * -- * Test_Log * SPEC -- * * -- ************************************************** package Test_Log is --| Purpose --| A Test Log is a log of test activity. Expected and --| Actual test results can be reported to it via the Compare --| routines, and Test Log can build a summary report of --| the test results. It keeps track of the number of --| tests and the number of errors detected. --| --| Test_Log provides a number of Compare routines --| that compare one value with another and two counters. --| The Test Counter is incremented each time a Compare --| routine is called and the Error counter is --| incremented each time the comparison does not work --| out. --| --| Test_Log performs its operations in one of three modes --| which may be selected by calling the Set_Mode routine: --| SILENT all results of calls to Compare are --| logged internally and no display is --| generated except when the Report --| routine is called --| VERBOSE all results of calls to Compare are --| displayed on the console --| REPORT_TO_FILE same as VERBOSE, except the results --| are written to a file rather than to --| the console --| --| A fourth "mode" is USER_SELECTABLE, which results in a --| prompt being displayed to the user and the user selecting --| one of the modes SILENT, VERBOSE, or REPORT_TO_FILE. --| --| Initialization Exceptions (none) --| Notes --| The Test and Error counters are initially set to --| zero. They may be reset to zero at any time by --| calling the Reset procedure. --| The Test and Error counters are of type NATURAL, --| so care should be exercised to see that no more --| tests than NATURAL'LAST are done before a Reset. --| --| Modifications --| 2/27/91 Richard Conn Initial Version and Release REPORT_FILE_ERROR : exception; -- raised if output report file cannot be created Test_Log_File : constant STRING := "testlog.rpt"; -- Name of test log file (see next comment) type MODE is (SILENT, VERBOSE, REPORT_TO_FILE, USER_SELECTABLE); -- The Test Log can run silently, displaying a summary report -- at the end, or verbosely, displaying each comparison as it -- is done. The REPORT_TO_FILE mode is the same as VERBOSE, -- but the output is sent to Test_Log_File rather than the -- console. USER_SELECTABLE causes the user to be prompted at -- the console and manually select the SILENT, VERBOSE, or -- REPORT_TO_FILE modes. type TEST_RESULT is (FAIL, PASS); -- Values of the result of a test -- .................................................. -- . . -- . Test_Log.Set_Mode . SPEC -- . . -- .................................................. procedure Set_Mode (To : in MODE); --| Purpose --| The mode of operation is set to the indicated mode. --| See the discussion above for a description of the --| modes. --| --| Exceptions (none) --| Notes --| If this routine is not called, the default mode --| is SILENT. -- .................................................. -- . . -- . Test_Log.Set_Test_ID_Field_Width . SPEC -- . . -- .................................................. procedure Set_Test_ID_Field_Width (To : in NATURAL := 10); --| Purpose --| Set the length of a test ID to be output (up to 60). --| Any test ID string shorter than this length will be --| padded with spaces. Any test ID string longer than --| this length will be output in full. --| --| Exceptions (none) --| Notes --| If this routine is not called, the field width is --| automatically set to the default value. -- .................................................. -- . . -- . Test_Log.Set_String_Field_Width . SPEC -- . . -- .................................................. procedure Set_String_Field_Width (To : in NATURAL := 20); --| Purpose --| Set the length of a string to be output (up to 60). --| Any string shorter than this length will be padded --| with spaces. Any string longer than this length --| will be output in full. --| --| Exceptions (none) --| Notes --| If this routine is not called, the field width is --| automatically set to the default value. -- .................................................. -- . . -- . Test_Log.Set_Integer_Field_Width . SPEC -- . . -- .................................................. procedure Set_Integer_Field_Width (To : in NATURAL := 20); --| Purpose --| Set the length of an integer to be output. --| If the integer requires more space than this, --| the necessary space will be taken. --| --| Exceptions (none) --| Notes --| If this routine is not called, the field width is --| automatically set to the default value. -- .................................................. -- . . -- . Test_Log.Set_Float_Field_Width . SPEC -- . . -- .................................................. procedure Set_Float_Field_Width (Before_Decimal : in NATURAL := 2; After_Decimal : in NATURAL := 5; In_Exponent : in NATURAL := 4); --| Purpose --| Set the length of the fields of a floating point --| value to be output. If In_Exponent is non-zero, --| scientific notation is used; if In_Exponent is --| zero, fixed point notation is used. --| --| Exceptions (none) --| Notes --| If this routine is not called, the field widths are --| automatically set to the default values. -- .................................................. -- . . -- . Test_Log.Reset . SPEC -- . . -- .................................................. procedure Reset; --| Purpose --| The Reset routine resets the test and error counters. --| It need not be called the first time this package's --| routines are used since these counters come up --| initialized. --| --| Exceptions (none) -- .................................................. -- . . -- . Test_Log.Compare . SPEC -- . . -- .................................................. procedure Compare(Test_ID : in STRING; Expected_Result : in STRING; Actual_Result : in STRING); procedure Compare(Test_ID : in STRING; Expected_Result : in INTEGER; Actual_Result : in INTEGER); procedure Compare(Test_ID : in STRING; Expected_Result : in FLOAT; Actual_Result : in FLOAT; Tolerance : in FLOAT); --| Purpose --| These routines compare the two values (x1 and x2) for --| equality (except in the case of F1 and F2, which are --| compared by abs(F1-F2)<Tolerance). If these values --| are equal or within tolerance, then only the --| Test counter is incremented. If these values are --| not equal or within tolerance, the Test counter and --| Error counter are incremented and the Test_ID is --| displayed. --| --| If the Mode (see the Set_Mode procedure) is SILENT, --| the results are not shown. If the Mode is VERBOSE --| or REPORT_TO_FILE, then the Test_ID, the Expected_Result, --| the Actual_Result, and the result of the comparison --| (FAIL or PASS) is written to the console (VERBOSE) --| or the output file Test_Log_File (REPORT_TO_FILE). --| --| Exceptions (none) -- .................................................. -- . . -- . Test_Log.Enter_Test_Result . SPEC -- . . -- .................................................. procedure Enter_Test_Result (Test_ID : in STRING; Result : in TEST_RESULT); --| Purpose --| This routine enters Result as though a Compare call --| was made. This is the same as calling one of the --| Compare routines, but the result of the comparison --| is the input value to this routine and no comparison --| is actually done. This is useful when a test does --| not generate a value as a result, such as when the --| test expects an exception to be raised. --| --| See the Purpose section of the Compare routines --| for more information. --| --| Exceptions (none) -- .................................................. -- . . -- . Test_Log.Error_Count . SPEC -- . . -- .................................................. function Error_Count return NATURAL; --| Purpose --| Error_Count returns the value of the Error Counter. --| --| Exceptions (none) -- .................................................. -- . . -- . Test_Log.Test_Count . SPEC -- . . -- .................................................. function Test_Count return NATURAL; --| Purpose --| Test_Count returns the value of the Test Counter. --| --| Exceptions (none) -- .................................................. -- . . -- . Test_Log.Write . SPEC -- . . -- .................................................. procedure Write(Message : in STRING := ""); --| Purpose --| Write the message to the console followed by a --| New Line. --| --| Exceptions (none) -- .................................................. -- . . -- . Test_Log.Report . SPEC -- . . -- .................................................. procedure Report(Message : in STRING := ""); --| Purpose --| Print a report showing the values of the Test and --| Error Counters. If Message is not null, it is --| printed, indented, before the counter values. --| --| Exceptions (none) -- .................................................. -- . . -- . Test_Log.Close . SPEC -- . . -- .................................................. procedure Close; --| Purpose --| Close the Test Log. If a Test_Log_File is open, --| it is closed. --| --| Exceptions (none) end Test_Log; --:::::::::: --binfile.spc --:::::::::: -- ************************************************** -- * * -- * Binary_File * SPEC -- * * -- ************************************************** with CS_Parts_Types; -- for BYTE type use CS_Parts_Types; package Binary_File is --| Purpose --| Binary_File provides a convenient mechanism for accessing --| binary files, implemented as an abstract data type. The --| binary file may be read or written one byte at a time. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| 7/15/90 Rick Conn Initial Design and Code type FILE_TYPE is limited private; type FILE_MODE is (IN_FILE, OUT_FILE); type BLOCK is array (INTEGER range <>) of BYTE; Data_Error, -- full BLOCK could not be read Device_Error, -- problem with underlying system End_Error, -- read attempted into end of file Mode_Error, -- read attempted from output file, etc. Name_Error, -- invalid file/dir name Status_Error, -- file already open Use_Error, -- write to read/only file, others Unexpected_Error : exception; -- ................................................... -- . . -- . Binary_File.Create . SPEC -- . . -- ................................................... procedure Create (File : in out FILE_TYPE; Name : in STRING); --| Purpose --| Create a binary file and open it for output. --| --| Exceptions --| Device_Error -- raised if file cannot be created --| -- due to a hardware error --| Name_Error -- raised if Name is not a valid file --| -- or directory reference --| Status_Error -- raised if file Name is already --| -- open --| Use_Error -- raised if file Name exists and is --| -- read/only --| --| Notes (none) -- ................................................... -- . . -- . Binary_File.Open . SPEC -- . . -- ................................................... procedure Open (File : in out FILE_TYPE; Name : in STRING); --| Purpose --| Open an existing binary file for input. --| --| Exceptions --| Device_Error -- raised if file cannot be opened --| -- due to a hardware error --| Name_Error -- raised if Name is not a valid file --| -- or directory reference --| Status_Error -- raised if file Name is already --| -- open --| Use_Error -- raised if file Name is write/only --| --| Notes (none) -- ................................................... -- . . -- . Binary_File.Close . SPEC -- . . -- ................................................... procedure Close (File : in out FILE_TYPE); --| Purpose --| Close the indicated file. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . Binary_File.Reset . SPEC -- . . -- ................................................... procedure Reset (File : in out FILE_TYPE; Mode : in FILE_MODE := IN_FILE); --| Purpose --| Close the indicated file and reopen it (at the --| beginning) for input or output. --| --| Exceptions --| Device_Error -- raised if file cannot be accessed --| -- due to a hardware error --| Name_Error -- raised if Name is not a valid file --| -- or directory reference --| Status_Error -- raised if file Name is already --| -- open --| Use_Error -- raised if file Name exists and is --| -- read/only --| --| Notes (none) -- ................................................... -- . . -- . Binary_File.Mode . SPEC -- . . -- ................................................... function Mode (File : in FILE_TYPE) return FILE_MODE; --| Purpose --| Return the mode (IN_FILE or OUT_FILE) of the --| indicated File. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . Binary_File.Name . SPEC -- . . -- ................................................... function Name (File : in FILE_TYPE) return STRING; --| Purpose --| Return the name of the indicated File. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . Binary_File.Is_Open . SPEC -- . . -- ................................................... function Is_Open (File : in FILE_TYPE) return BOOLEAN; --| Purpose --| Return TRUE iff the indicated File is open. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . Binary_File.Is_End . SPEC -- . . -- ................................................... function Is_End (File : in FILE_TYPE) return BOOLEAN; --| Purpose --| Return TRUE if the next byte to be returned from --| the indicated File is beyond the end of the file. --| --| Exceptions (none) --| Notes (none) -- ................................................... -- . . -- . Binary_File.Read . SPEC -- . . -- ................................................... procedure Read (File : in FILE_TYPE; Item : out BYTE); --| Purpose --| Read the next byte from an OPENed File. --| --| Exceptions --| Device_Error -- raised if File cannot be accessed --| -- due to a hardware error --| End_Error -- raised if the next byte to be --| -- returned is beyond the end of --| -- the File --| Mode_Error -- raised if File is opened for --| -- output (mode OUT_FILE) --| Status_Error -- raised if File has not been --| -- OPENed --| --| Notes (none) -- ................................................... -- . . -- . Binary_File.Read . SPEC -- . . -- ................................................... procedure Read (File : in FILE_TYPE; Item : out BLOCK); --| Purpose --| Read the next block from an OPENed File. --| --| Exceptions --| Data_Error -- raised if a full BLOCK could --| -- not be read from the file --| Device_Error -- raised if File cannot be accessed --| -- due to a hardware error --| End_Error -- raised if the next byte to be --| -- returned is beyond the end of --| -- the File --| Mode_Error -- raised if File is opened for --| -- output (mode OUT_FILE) --| Status_Error -- raised if File has not been --| -- OPENed --| --| Notes (none) -- ................................................... -- . . -- . Binary_File.Write . SPEC -- . . -- ................................................... procedure Write (File : in FILE_TYPE; Item : in BYTE); --| Purpose --| Write the next byte to a CREATEed File. --| --| Exceptions --| Device_Error -- raised if File cannot be accessed --| -- due to a hardware error --| Mode_Error -- raised if File is opened for --| -- input (mode IN_FILE) --| Status_Error -- raised if File has not been --| -- CREATEd --| --| Notes (none) -- ................................................... -- . . -- . Binary_File.Write . SPEC -- . . -- ................................................... procedure Write (File : in FILE_TYPE; Item : in BLOCK); --| Purpose --| Write the next block to a CREATEed File. --| --| Exceptions --| Device_Error -- raised if File cannot be accessed --| -- due to a hardware error --| Mode_Error -- raised if File is opened for --| -- input (mode IN_FILE) --| Status_Error -- raised if File has not been --| -- CREATEd --| --| Notes (none) private type FILE_OBJECT; -- deferred to body type FILE_TYPE is access FILE_OBJECT; end Binary_File; --:::::::::: --bintree2.spc --:::::::::: -- *********************************************** -- * * -- * BINARYTREES * SPEC -- * * -- *********************************************** with Lists; generic type ITEMTYPE is private; with function "<" (X,Y: in ITEMTYPE) return BOOLEAN; package BinaryTrees is --| Purpose --| 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. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Bill Toscano and Michael Gordon, Intermetrics 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. -- ................................................. -- . . -- . BINARYTREES.CREATE . SPEC -- . . -- ................................................. function Create return TREE; --| Purpose --| This creates a tree containing no information and no children. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . BINARYTREES.DEPOSIT . SPEC -- . . -- ................................................. procedure Deposit (I : in ITEMTYPE; S : in TREE); --| Purpose --| This changes the information stored at the root of the tree S. --| It deposits the information I in the root of S. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . BINARYTREES.DESTROYTREE . SPEC -- . . -- ................................................. procedure DestroyTree (T :in out TREE); --| Purpose --| Destroys a tree and returns the space which it is occupying. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . BINARYTREES.INSERTNODE . SPEC -- . . -- ................................................. Procedure Insertnode(N : In Out ITEMTYPE; T : In Out TREE; Root : Out TREE; Exists : out BOOLEAN); --| Purpose --| This adds the node N to the tree T inserting in the proper position. --| Root is the root of the subtree which Node N heads (the position --| of Node N in T). --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . BINARYTREES.MAKETREEITER . SPEC -- . . -- ................................................. function MakeTreeIter (T : in TREE) return TREEITER; --| Purpose --| 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 deepest --| leftmost leaf in the tree. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . BINARYTREES.MORE . SPEC -- . . -- ................................................. function More (I : in TREEITER) return BOOLEAN; --| Purpose --| Returns TRUE iff there are more elements in the tree --| over which to iterate. --| --| Exceptions (none) --| Notes (none) -- ................................................. -- . . -- . BINARYTREES.NEXT . SPEC -- . . -- ................................................. procedure Next (I : in out TREEITER; Info : out ITEMTYPE); --| Purpose --| 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, More will indicate such. --| --| Exceptions (none) --| Notes (none) private type NODE; type TREE is access NODE; type NODE is record Info : ITEMTYPE; LeftChild : TREE; RightChild : TREE; end record; package NodeOrder is new Lists (TREE); type TREEITER is record NodeList : NodeOrder.LIST; State : NodeOrder.LISTITER; end record; end BinaryTrees; --:::::::::: --hashmap.spc --:::::::::: -- ****************************************************** -- * * -- * Hashed_Mapping_PKG * SPEC -- * * -- ****************************************************** with lists; -- Lists used in implementation. (private) pragma elaborate(lists); generic type KEY_TYPE is private; with function Equal (K1, K2: KEY_TYPE) return BOOLEAN is "="; type BUCKET_RANGE is range <>; -- Defines the number of hash buckets, one for each member -- of BUCKET_RANGE. with function Hash (K: KEY_TYPE) return BUCKET_RANGE; -- Required property: equal(e1, e2) => hash(e1) = hash(e2). -- Best results if hash produces a uniform distribution -- over BUCKET_RANGE. type VALUE_TYPE is private; package Hashed_Mapping_PKG is --| Purpose --| This package provides a mapping from one arbitrary type, --| KEY_TYPE, to another arbitrary type, VALUE_TYPE. These --| types are generic formals to the package, along with an --| equality relation on KEY_TYPE, an integer subtype that --| determines the number of hash buckets, and a hashing --| function on KEY_TYPE that maps to that integer subtype. --| --| For the purpose of specifying the operations in this --| package, we will view a mapping as a set of bindings, --| or key/value pairs. This allows the use of set notation --| in description. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Ron Kownacki, Intermetrics type MAPPING is private; No_More: exception; -- Raised on incorrect use of an iterator. Uninitialized_Mapping: exception; -- Raised on use of an unitialized MAPPING by most operations. Already_Bound: exception; -- Raised on attempt to rebind a key that is currently bound. Not_Bound: exception; -- Raised when a key that is expected to be bound is unbound. type KEYS_ITER is private; -- Bound keys in arbitrary order. type VALUES_ITER is private; -- Bound values in arbitrary order. type BINDINGS_ITER is private; -- Key,value pairs in arbitrary order -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Create . SPEC -- . . -- ....................................................... function Create return MAPPING; --| Purpose --| Return {}. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Bind . SPEC -- . . -- ....................................................... procedure Bind (Map: in out MAPPING; Key: in KEY_TYPE; Value: in VALUE_TYPE); --| Purpose --| Insert the binding, <key, value>, into map. Raises --| already_bound iff a pair, <k', v'>, where equal(key, k'), --| is in map. Raises Uninitialized_Mapping iff map has --| not been initialized. --| --| Exceptions --| Already_Bound --| Uninitialized_Mapping --| --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Unbind . SPEC -- . . -- ....................................................... procedure Unbind (Map: in out MAPPING; Key: in KEY_TYPE); --| Purpose --| If <k, v>, where equal(key, k), is in map, then removes --| <k, v> from map. Raises not_bound if no such pair exists. --| Raises Uninitialized_Mapping iff map has not been initialized. --| --| Exceptions --| Not_Bound --| Uninitialized_Mapping --| --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Copy . SPEC -- . . -- ....................................................... function Copy (Map: MAPPING) return MAPPING; --| Purpose --| Returns a copy of map. Subsequent changes to map will not be --| visible through applying operations to the copy of map. --| Assignment or parameter passing without copying will result --| in a single MAPPING value being shared among MAPPING objects. --| Raises Uninitialized_Mapping iff map has not been initialized. --| The assignment operation is used to transfer the values of the --| KEY_TYPE and VALUE_TYPE type COMPONENTs of map; consequently, --| changes in the values of these types may be observable through --| both MAPPINGs if these are access types, or if they contain --| COMPONENTs of an access type. --| --| Exceptions --| Uninitialized_Mapping --| --| Notes (none) -- Query Operations: -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Is_Empty . SPEC -- . . -- ....................................................... function Is_Empty (Map: MAPPING) return BOOLEAN; --| Purpose --| Return map = {}. --| Raises Uninitialized_Mapping iff map has not been --| initialized. --| --| Exceptions --| Uninitialized_Mapping --| --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Size . SPEC -- . . -- ....................................................... function Size (Map: MAPPING) return NATURAL; --| Purpose --| Return |map|, the number of bindings in map. --| Raises Uninitialized_Mapping iff map has not been --| initialized. --| --| Exceptions --| Uninitialized_Mapping --| --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Is_Bound . SPEC -- . . -- ....................................................... function Is_Bound (Map: MAPPING; Key: KEY_TYPE) return BOOLEAN; --| Purpose --| Return true iff equal(key, k) for some <k, v> in map. --| Raises Uninitialized_Mapping iff map has not been --| initialized. --| --| Exceptions --| Uninitialized_Mapping --| --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Fetch . SPEC -- . . -- ....................................................... function Fetch (Map: MAPPING; Key: KEY_TYPE) return VALUE_TYPE; --| Purpose --| If <k, v>, where equal(key, k), is in map, then return v. --| Raises not_bound if no such <k, v> exists. --| Raises Uninitialized_Mapping iff map has not been --| initialized. --| --| Exceptions --| Not_Bound --| Uninitialized_Mapping --| --| Notes (none) -- Iterators: -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Make_Keys_Iter . SPEC -- . . -- ....................................................... function Make_Keys_Iter (Map: MAPPING) return KEYS_ITER; --| Purpose --| Create and return a keys iterator based on map. This --| object can then be used in conjunction with the more --| function and the next procedure to iterate over all keys --| that are bound in map. Raises Uninitialized_Mapping iff --| map has not been initialized. --| --| Exceptions --| Uninitialized_Mapping --| --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.More . SPEC -- . . -- ....................................................... function More (Iter: KEYS_ITER) return BOOLEAN; --| Purpose --| Return true iff the keys iterator has not been exhausted. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Next . SPEC -- . . -- ....................................................... procedure Next (Iter: in out KEYS_ITER; Key: out KEY_TYPE); --| Purpose --| Let iter be based on the MAPPING, map. Successive calls --| of next will return the bound keys of map in some --| arbitrary order. After all bound keys have been returned, --| then the procedure will raise no_more. --| --| Exceptions --| No_More --| --| Notes --| Map must not be changed between the invocations of --| Make_Keys_Iterator (Map) and Next. -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Make_Values_Iter . SPEC -- . . -- ....................................................... function Make_Values_Iter (Map: MAPPING) return VALUES_ITER; --| Purpose --| Create and return a values iterator based on map. This --| object can then be used in conjunction with the more --| function and the next procedure to iterate over all values --| that are bound to keys in map. --| Raises Uninitialized_Mapping iff map has not been --| initialized. --| --| Exceptions --| Uninitialized_Mapping --| --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.More . SPEC -- . . -- ....................................................... function More (Iter: VALUES_ITER) return BOOLEAN; --| Purpose --| Return true iff the values iterator has not been exhausted. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Next . SPEC -- . . -- ....................................................... procedure Next (Iter: in out VALUES_ITER; Val: out VALUE_TYPE); --| Purpose --| Let iter be based on the MAPPING, map. Successive calls --| of next will return the bound values of map in some --| arbitrary order. After all bound values have been returned, --| then the procedure will raise no_more. --| --| Exceptions --| No_More --| --| Notes --| Map must not be changed between the invocations of --| Make_Values_Iterator (Map) and Next. -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Make_Keys_Iter . SPEC -- . . -- ....................................................... function Make_Bindings_Iter (Map: MAPPING) return BINDINGS_ITER; --| Purpose --| Create and return a bindings iterator based on map. --| This object can then be used in conjunction with the --| more function and the next procedure to iterate over --| all key/value pairs in map. Raises Uninitialized_Mapping --| iff map has not been initialized. --| --| Exceptions --| Uninitialized_Mapping --| --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.More . SPEC -- . . -- ....................................................... function More (Iter: BINDINGS_ITER) return BOOLEAN; --| Purpose --| Return true iff the bindings iterator has not been exhausted. --| --| Exceptions (none) --| Notes (none) -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Next . SPEC -- . . -- ....................................................... procedure Next (Iter: in out BINDINGS_ITER; Key: out KEY_TYPE; Val: out VALUE_TYPE); --| Purpose --| Let iter be based on the MAPPING, map. Successive calls --| of next will return the key/value pairs of map in some --| arbitrary order. After all such pairs have been returned, --| then the procedure will raise no_more. --| --| Exceptions --| No_More --| --| Notes --| Map must not be changed between the invocations of --| Make_Bindings_Iterator (Map) and Next. -- Heap management: -- ....................................................... -- . . -- . Hashed_Mapping_PKG.Destroy . SPEC -- . . -- ....................................................... procedure Destroy (M: in out MAPPING); --| Purpose --| Return space consumed by MAPPING value associated with --| object m to the heap. (If m is uninitialized, this --| operation does nothing.) If other objects share the --| same MAPPING value, the further use of these objects is --| erroneous. COMPONENTs of type VALUE_TYPE, if they are --| access types, are not garbage collected. It is the user's --| responsibility to dispose of these objects. m is left in --| the uninitialized state. --| --| Exceptions (none) --| Notes (none) private type COMPONENT is record Key: KEY_TYPE; Val: VALUE_TYPE; end record; function Equal (C1, C2: COMPONENT) return BOOLEAN; -- Return true iff equal(c1.key, c2.key). package Bucket_PKG is new Lists (COMPONENT, Equal); use Bucket_PKG; type BUCKET_ARRAY is array (BUCKET_RANGE) of LIST; type MAPPING_REC is record Size : NATURAL; Buckets : BUCKET_ARRAY; end record; type MAPPING is access MAPPING_REC; -- Representation Invariants: -- 1. r /= null. (This would be the uninitialized case) -- 2. If for some i, a COMPONENT, c, is in bucket r.buckets(i), -- then hash(c.key) = i. -- 3. If a COMPONENT, c1, is in bucket, r.buckets(i), then there is -- no other c2 in r.buckets(i) such that equal(c1, c2). -- (Enforce one binding to a given key at any time.) -- 4. r.size equals the total number of COMPONENTs in buckets -- r.buckets(BUCKET_RANGE'first) through -- r.buckets(BUCKET_RANGE'last). -- -- Abstraction Function: -- A(r) is the set consisting of all key, value pairs that appear as -- COMPONENTs in buckets r.buckets(BUCKET_RANGE'first) through -- r.buckets(BUCKET_RANGE'last). type GENERAL_ITER is record Map : MAPPING; Current : BUCKET_RANGE; Position : LIST; end record; -- For a given general_iter, i, the make, more and next operations -- have the following effects: -- make: Sets map field to the given MAPPING, sets i.current to the -- lowest idx of a nonempty bucket, and sets i.position to the head -- of that bucket. -- more: Returns not empty(i.position). -- next: key, val fields of first COMPONENT of i.position. -- Advances i.position to next COMPONENT in bucket, if it exists. -- Otherwise, increments i.current until a nonempty bucket, and sets -- i.position to this bucket. When this fails, sets i.position to an -- empty bucket. type KEYS_ITER is new general_iter; type VALUES_ITER is new general_iter; type BINDINGS_ITER is new general_iter; end Hashed_Mapping_PKG; --:::::::::: --ltrees.spc --:::::::::: -- ************************************************* -- * * -- * LABELED_TREES * SPEC -- * * -- ************************************************* with Lists; generic type LABEL_TYPE is private; -- This is used to identify nodes in the tree. type VALUE_TYPE is private; -- Information being contained in a node of tree with function "<" (X: in LABEL_TYPE; Y: in LABEL_TYPE) return BOOLEAN is <> ; -- Function which defines ordering of nodes -- a < b -> not (b < a) and (b /= a) for all a and b. package Labeled_Trees is --| Purpose --| This package creates an ordered binary tree. This will allow for --| quick insertion, and search. --| --| The tree is organized such that --| --| label (leftchild) < label (root) label (root) < label (rightchild) --| --| This means that by doing a left to right search of the tree will --| produce the nodes of the tree in ascending order. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Bill Toscano and Michael Gordon, Intermetrics, Inc. type TREE is private; type TREE_ITER is private; Label_Already_Exists_In_Tree : exception; Label_Not_Present : exception; No_More : exception; Tree_Is_Empty : exception; -- .................................................... -- . . -- . LABELED_TREES.CREATE . SPEC -- . . -- .................................................... function Create return TREE; --| Purpose --| This creates a tree containing no information and no children. An --| emptytree. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.DESTROY_DEEP_TREE . SPEC -- . . -- .................................................... generic with procedure Dispose_Label (L :in out LABEL_TYPE); with procedure Dispose_Value (V :in out VALUE_TYPE); procedure Destroy_Deep_Tree (T : in out TREE); --| Purpose --| Destroys all nodes in a tree and the label and value associated --| with each node. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.DESTROY_TREE . SPEC -- . . -- .................................................... procedure Destroy_Tree (T : in out TREE); --| Purpose --| Destroys a tree and returns the space which it is occupying. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.FETCH_VALUE . SPEC -- . . -- .................................................... function Fetch_Value (T : in TREE; L : in LABEL_TYPE) return VALUE_TYPE; --| Purpose --| Get the value of the node with the given label. --| If the label is not present Label_Not_Present is raised. --| --| Exceptions --| Label_Not_Present --| --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.FETCH_VALUE . SPEC -- . . -- .................................................... function Fetch_Value (T : in TREE) return VALUE_TYPE; --| Purpose --| Return the value stored at the root node of the given tree. --| Raises Label_Not_Present if the tree T is empty. --| --| Exceptions --| Label_Not_Present --| --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.GET_TREE . SPEC -- . . -- .................................................... function Get_Tree (T : in TREE; L : in LABEL_TYPE) return TREE; --| Purpose --| Get the subtree whose root is labelled L. --| --| Exceptions --| Label_Not_Present if the label L is not in T --| --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.FORWARD . SPEC -- . . -- .................................................... procedure Forward (I : in out TREE_ITER); --| Purpose --| This is used to advance the iterator. Typically this is used in --| conjunction with Node_Value and Node_Label. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.INSERT_NODE . SPEC -- . . -- .................................................... procedure Insert_Node (T : in out TREE; L : in LABEL_TYPE; V : in VALUE_TYPE); --| Purpose --| Inserts a node into the specified tree. --| This adds the node with label L to the tree T. Label_Already_Exists is --| raised if L already exists in T. --| --| Exceptions --| Label_Already_Exists --| --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.IS_EMPTY . SPEC -- . . -- .................................................... function Is_Empty (T : in TREE) return BOOLEAN; --| Purpose --| Returns TRUE iff the tree is empty. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.IS_LABEL_IN_TREE . SPEC -- . . -- .................................................... function Is_Label_In_Tree (T : in TREE; L : in LABEL_TYPE) return BOOLEAN; --| Purpose --| Returns TRUE iff the given labels is in the given tree. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.IS_LABEL_IN_TREE . SPEC -- . . -- .................................................... procedure Is_Label_In_Tree (T : in TREE; L : in LABEL_TYPE; Subtree : out TREE; Present : out BOOLEAN); --| Purpose --| This operation can be used to see if a label is in the tree. --| It sets the variable Present to TRUE iff the given label is in --| the given tree. --| If it is, the Subtree out parameter can then be used to --| to update the value field of the label. The sequence would be --| --| Is_Label_In_Tree (T, L, Subtree, Present); --| if Present then --| Store_Value (Subtree, SomeValue); --| end if; --| --| If the label is not Present, then Subtree is the root of the tree --| where the label would be stored if it were present. Thus the following --| sequence would be useful. --| --| Is_Label_In_Tree (T, L, Subtree, Present); --| if not Present then --| Insert_Node (Subtree, L, V); --| end if; --| --| The advantage to this routine is that the tree need only be searched --| once instead of twice once for the existence check and then once for --| the insertion. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.ITERATOR_LABEL . SPEC -- . . -- .................................................... function Iterator_Label (I : in TREE_ITER) return LABEL_TYPE; --| Purpose --| Returns the label of the node corresponding to the iterator. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.ITERATOR_VALUE . SPEC -- . . -- .................................................... function Iterator_Value (I : in TREE_ITER) return VALUE_TYPE; --| Purpose --| Returns the value of the node corresponding to the iterator. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.MAKE_TREE . SPEC -- . . -- .................................................... function Make_Tree (L : in LABEL_TYPE; V : in VALUE_TYPE) return TREE; --| Purpose --| Creates a tree whose root has the given label and value. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.MAKE_TREE_ITER_IN . SPEC -- . . -- .................................................... function Make_Tree_Iter_In (T : in TREE) return TREE_ITER; --| Purpose --| This sets up an iteration of the nodes of the tree in inorder. --| By using the Next operations the nodes of the tree are returned in --| in inorder. Inorder means return the left child then the node --| then the right child. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.MAKE_TREE_ITER_POST . SPEC -- . . -- .................................................... function Make_Tree_Iter_Post (T : in TREE) return TREE_ITER; --| Purpose --| This sets up an iteration of the nodes of the tree in postorder. --| By using the Next operations the nodes of the tree are returned in --| post order. Post order means return the node first then its left child --| and then its right child. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.MAKE_TREE_ITER_PRE . SPEC -- . . -- .................................................... function Make_Tree_Iter_Pre (T : in TREE) return TREE_ITER; --| Purpose --| This sets up an iteration of the nodes of the tree in preorder. --| By using the Next operations the nodes of the tree are returned in --| ascending order. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.MORE . SPEC -- . . -- .................................................... function More (I : in TREE_ITER) return BOOLEAN; --| Purpose --| Returns TRUE iff there are more elements in the tree to --| iterate over. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.NEXT . SPEC -- . . -- .................................................... procedure Next (I : in out TREE_ITER; V : out VALUE_TYPE); --| Purpose --| This returns the next element in the iteration and advances the iterator. --| No_More is raised when after the last element has been returned and --| an attempt is made to get another element. --| --| Exceptions --| No_More --| --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.NEXT . SPEC -- . . -- .................................................... procedure Next (I : in out TREE_ITER; V : out VALUE_TYPE; L : out LABEL_TYPE); --| Purpose --| This iteration operation returns the label of a node as well as the --| node's value. No_More is raised if Next is called after the last --| element of the tree has been returned. --| --| Exceptions --| No_More --| --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.STORE_VALUE . SPEC -- . . -- .................................................... procedure Store_Value (T : in out TREE; L : in LABEL_TYPE; V : in VALUE_TYPE); --| Purpose --| Sets a new value V in the tree T at the node identified --| by the label L. --| Label_Not_Present is raised if L is not in T. --| --| Exceptions --| Label_Not_Present --| --| Notes (none) -- .................................................... -- . . -- . LABELED_TREES.STORE_VALUE . SPEC -- . . -- .................................................... procedure Store_Value (T : in out TREE; V : in VALUE_TYPE); --| Purpose --| This stores the value V in the root node of the tree T. --| Raises Label_Not_Present if T is empty. --| --| Exceptions --| Label_Not_Present --| --| Notes (none) private type NODE; type TREE is access NODE; type NODE is record Label : LABEL_TYPE; Value : VALUE_TYPE; Left_Child : TREE; Right_Child : TREE; end record; package NODE_ORDER is new Lists (TREE); type TREE_ITER is record Node_List : Node_Order.LIST; State : Node_Order.LISTITER; end record; end Labeled_Trees; --:::::::::: --set.spc --:::::::::: -- ************************************************ -- * * -- * SET_PKG * SPEC -- * * -- ************************************************ with Lists; pragma Elaborate (Lists); generic type ELEM_TYPE is private; with function Equal (E1, E2: ELEM_TYPE) return BOOLEAN is "="; package Set_Pkg is --| Purpose --| This package provides the set abstract data type. All standard set --| operations are provided. Standard mathematical set notation is --| employed to describe the effects of the operations. --| --| The component type, and an equality relation used for membership --| tests, are generic formals of the package. The implementation isn't --| particularly fast, since the only available information about the --| component type is the equality relation. However, this shouldn't be a --| concern unless the sets become large or speed becomes important. --| See scalar_set_pkg, hashed_set_pkg and ordered_set_pkg for other --| implementations. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Programmer: Ron Kownacki, Intermetrics --| One of a family of set packages: type SET is private; -- Exceptions: No_More: exception; -- Raised on incorrect use of an iterator. -- Iterators: type MEMBERS_ITER is private; -- Members of a set in arbitrary order -- Constructors: -- ............................................... -- . . -- . SET_PKG.CREATE . SPEC -- . . -- ............................................... function Create return SET; --| Purpose --| Return {}. This operation is not strictly necessary, since an --| uninitialized set object is viewed as the empty set. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . SET_PKG.INSERT . SPEC -- . . -- ............................................... procedure Insert (S: in out SET; E: in ELEM_TYPE); --| Purpose --| Insert the element, e, into the set, s. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . SET_PKG.DELETE . SPEC -- . . -- ............................................... procedure Delete (S: in out SET; E: in ELEM_TYPE); --| Purpose --| If e is in s, then remove e from s. Otherwise, no effect. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . SET_PKG.INTERSECT . SPEC -- . . -- ............................................... function Intersect (S1, S2: SET) return SET; --| Purpose --| Return {e | member(s1, e) and member(s2, e)}. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . SET_PKG.UNION . SPEC -- . . -- ............................................... function Union (S1, S2: SET) return SET; --| Purpose --| Return {e | member(s1, e) or member(s2, e)}. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . SET_PKG.COPY . SPEC -- . . -- ............................................... function Copy (S: SET) return SET; --| Purpose --| Returns a copy of s. Subsequent changes to s will not be --| visible through the application of operations to the copy of s. --| Assignment or parameter passing without copying will result --| in a single set value being shared among objects. --| The assignment operation is used to transfer the values of --| the elem_type components of s; consequently, changes in these --| values may be observable through both sets if these types are --| access types, or if they contain access type components. --| --| Exceptions (none) --| Notes (none) -- Query Operations -- ............................................... -- . . -- . SET_PKG.EQUAL . SPEC -- . . -- ............................................... function Equal (S1, S2: SET) return BOOLEAN; --| Purpose --| Return (for all e: elem_type (member(s1, e) iff member(s2, e))). --| Note that (s1 = s2) implies equal(s1, s2) holds for all time. --| "=" is object equality, equal is state equality. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . SET_PKG.IS_EMPTY . SPEC -- . . -- ............................................... function Is_Empty (S: SET) return BOOLEAN; --| Purpose --| Return s = {}. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . SET_PKG.IS_MEMBER . SPEC -- . . -- ............................................... function Is_Member (S: SET; E: ELEM_TYPE) return BOOLEAN; --| Purpose --| Return true iff e is a member of s. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . SET_PKG.SIZE . SPEC -- . . -- ............................................... function Size (S: SET) return NATURAL; --| Purpose --| Return |s|, the cardinality of s. --| --| Exceptions (none) --| Notes (none) -- Iterators -- ............................................... -- . . -- . SET_PKG.MAKE_MEMBERS_ITER . SPEC -- . . -- ............................................... function Make_Members_Iter (S: SET) return MEMBERS_ITER; --| Purpose --| Create and return a members iterator based on s. This object --| can then be used in conjunction with the more function and the --| next procedure to iterate over the members of s in some --| arbitrary order. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . SET_PKG.MORE . SPEC -- . . -- ............................................... function More (Iter: MEMBERS_ITER) return BOOLEAN; --| Purpose --| Return true iff the members iterator has not been exhausted. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . SET_PKG.NEXT . SPEC -- . . -- ............................................... procedure Next (Iter: in out MEMBERS_ITER; E: out ELEM_TYPE); --| Purpose --| Let iter be based on the set, s. Successive calls of next --| will return the members of s in some arbitrary order. --| After all members have been returned, then the procedure will --| raise no_more. --| Requires: --| s must not be changed between the invocations of --| make_nodes_iterator(g) and next. --| --| Exceptions --| no_more --| --| Notes (none) -- Heap management -- ............................................... -- . . -- . SET_PKG.DESTROY . SPEC -- . . -- ............................................... procedure Destroy (S: in out SET); --| Purpose --| Return space consumed by the set value associated with object --| s to the heap. If other objects share the same set value, then --| further use of these objects is erroneous. Components of type --| elem_type, if they are access types, are not garbage collected. --| It is the user's responsibility to dispose of these objects. --| s is set to {}. --| --| Exceptions (none) --| Notes (none) private package List_Pkg is new Lists (ELEM_TYPE, Equal); use List_Pkg; type SET is new LIST; -- Representation Invariants: -- None; all lists are legal representations of sets. -- Abstraction Function: A: representation --> set -- A(null) = create. -- A(attach(r, e)) = insert(A(r), e). -- Sufficient since all lists can be generated by null, attach. -- -- Note that this implementation allows faster insertion and -- membership testing than if duplicate insertions of an element -- caused a check to ensure that each element is only kept once in -- the list. This implies that deleting an element always involves -- a scan of the entire list. type MEMBERS_ITER is new LIST; -- For a set, s, make returns members_iter(copy(list(s))). -- More(iter) returns true iff list(iter) isn't empty. -- Next(iter) returns the first element in list(iter). Before doing -- this, it removes all occurrences of this element from list(iter). end Set_Pkg; --:::::::::: --stack.spc --:::::::::: -- ************************************************** -- * * -- * STACK_PKG * SPEC -- * * -- ************************************************** with Lists; generic type ELEM_TYPE is private; package Stack_Pkg is --| Purpose --| This package provides the stack abstract data type. Element type is --| a generic formal parameter to the package. There are no explicit --| bounds on the number of objects that can be pushed onto a given stack. --| All standard stack operations are provided. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Programmer: Ron Kownacki, Intermetrics type STACK is private; -- Exceptions: Uninitialized_Stack: exception; -- Raised on attempt to manipulate an uninitialized stack object. -- The initialization operations are create and copy. Empty_Stack: exception; -- Raised by some operations when empty. -- Constructors: -- .............................................................. -- . . -- . STACK_PKG.CREATE . SPEC -- . . -- .............................................................. function Create return STACK; --| Purpose --| Return the empty stack. --| --| Exceptions (none) --| Notes (none) -- .............................................................. -- . . -- . STACK_PKG.PUSH . SPEC -- . . -- .............................................................. procedure Push (S: in out STACK; E: in ELEM_TYPE); --| Purpose --| Push e onto the top of s. --| Raises uninitialized_stack iff s has not been initialized. --| --| Exceptions --| uninitialized_stack --| --| Notes (none) -- .............................................................. -- . . -- . STACK_PKG.POP . SPEC -- . . -- .............................................................. procedure Pop (S: in out STACK); --| Purpose --| Pops the top element from s, and throws it away. --| Raises empty_stack iff s is empty. --| Raises uninitialized_stack iff s has not been initialized. --| --| Exceptions --| empty_stack --| uninitialized_stack --| --| Notes (none) -- .............................................................. -- . . -- . STACK_PKG.POP . SPEC -- . . -- .............................................................. procedure Pop (S: in out STACK; E: out ELEM_TYPE); --| Purpose --| Pops the top element from s, returns it as the e parameter. --| Raises empty_stack iff s is empty. --| Raises uninitialized_stack iff s has not been initialized. --| --| Exceptions --| empty_stack --| uninitialized_stack --| --| Notes (none) -- .............................................................. -- . . -- . STACK_PKG.COPY . SPEC -- . . -- .............................................................. function Copy (S: STACK) return STACK; --| Purpose --| Return a copy of s. --| Stack assignment and passing stacks as subprogram parameters --| result in the sharing of a single stack value by two stack --| objects; changes to one will be visible through the others. --| copy can be used to prevent this sharing. --| Raises uninitialized_stack iff s has not been initialized. --| --| Exceptions --| uninitialized_stack --| --| Notes (none) -- Queries: -- .............................................................. -- . . -- . STACK_PKG.TOP . SPEC -- . . -- .............................................................. function Top (S: STACK) return ELEM_TYPE; --| Purpose --| Return the element on the top of s. Raises empty_stack iff s is --| empty. --| Raises uninitialized_stack iff s has not been initialized. --| --| Exceptions --| empty_stack --| uninitialized_stack --| --| Notes (none) -- .............................................................. -- . . -- . STACK_PKG.SIZE . SPEC -- . . -- .............................................................. function Size (S: STACK) return NATURAL; --| Purpose --| Return the current number of elements in s. --| Raises uninitialized_stack iff s has not been initialized. --| --| Exceptions --| uninitialized_stack --| --| Notes (none) -- .............................................................. -- . . -- . STACK_PKG.IS_EMPTY . SPEC -- . . -- .............................................................. function Is_Empty (S: STACK) return BOOLEAN; --| Purpose --| Return true iff s is empty. --| Raises uninitialized_stack iff s has not been initialized. --| --| Exceptions --| uninitialized_stack --| --| Notes (none) -- Heap Management: -- .............................................................. -- . . -- . STACK_PKG.DESTROY . SPEC -- . . -- .............................................................. procedure Destroy (S: in out STACK); --| Purpose --| Return the space consumed by s to the heap. No effect if s is --| uninitialized. In any case, leaves s in uninitialized state. --| --| Exceptions (none) --| Notes (none) private package Elem_List_Pkg is new Lists (ELEM_TYPE); subtype ELEM_LIST is Elem_List_Pkg.LIST; type STACK_REC is record Size: NATURAL := 0; Elts: ELEM_LIST := Elem_List_Pkg.Create; end record; type STACK is access STACK_REC; -- Let an instance of the representation type, r, be denoted by the -- pair, <size, elts>. Dot selection is used to refer to these -- components. -- -- Representation Invariants: -- r /= null -- elem_list_pkg.length(r.elts) = r.size. -- -- Abstraction Function: -- A(<size, elem_list_pkg.create>) = stack_pkg.create. -- A(<size, elem_list_pkg.attach(e, l)>) = push(A(<size, l>), e). end Stack_Pkg; --:::::::::: --clp.spc --:::::::::: -- ********************************************** -- * * -- * COMMAND_LINE_PROCESSOR (CLP) * SPEC -- * * -- ********************************************** package Command_Line_Processor is --| Purpose --| COMMAND_LINE_PROCESSOR is an abstract state machine --| that allows the user to access a command line, which --| may contain file references which are include files, --| as a simple list of file names which can be accessed --| via an interator and a Get function. The command line --| syntax is: --| --| command input_file input_file ... output_file --| or: --| command input_file input_file ... input_file --| --| where any "input_file" may be prefixed by an "@" --| to make it an include file. --| --| Initialization Exceptions (none) --| Notes (none) --| Modifications --| 2/19/90 Rick Conn Initial Design and Code type COMMAND_LINE_LAYOUT is (ALL_INPUT_FILES, ONE_OUTPUT_FILE); -- the command line either contains only input -- files or a group of input files and one -- output file -- .............................................. -- . . -- . CLP.INITIALIZE . SPEC -- . . -- .............................................. procedure Initialize (Program_Name : in STRING; Command_Kind : in COMMAND_LINE_LAYOUT := ONE_OUTPUT_FILE); --| Purpose --| Initialize the package, specifying a program --| name which may be used by the Command Line --| Interface --| --| Exceptions --| ALLOCATION_PROBLEM --| INIT_ERROR --| --| Notes --| CALL INITIALIZE ONLY ONCE -- .............................................. -- . . -- . CLP.RESET . SPEC -- . . -- .............................................. procedure Reset; --| Purpose --| Reset the iterator. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . CLP.IS_END . SPEC -- . . -- .............................................. function Is_End return BOOLEAN; --| Purpose --| Return TRUE if no more file names are --| available. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . CLP.FILE_NAME . SPEC -- . . -- .............................................. function File_Name return STRING; --| Purpose --| Return the name of the next file. --| --| Exceptions --| END_OF_FILE_LIST --| --| Notes (none) -- .............................................. -- . . -- . CLP.OUTPUT_FILE_NAME . SPEC -- . . -- .............................................. function Output_File_Name return STRING; --| Purpose --| Return the name of the output file. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . CLP.FILE_NAME_COUNT . SPEC -- . . -- .............................................. function File_Name_Count return NATURAL; --| Purpose --| Number of file names in command line. ALLOCATION_PROBLEM : exception; END_OF_FILE_LIST : exception; INIT_ERROR : exception; UNEXPECTED_ERROR : exception; -- raised anytime end Command_Line_Processor; --:::::::::: --lbintree.spc --:::::::::: -- ******************************************************** -- * * -- * LABELED_BINARY_TREES_PKG * SPEC -- * * -- ******************************************************** with Binary_Trees_Pkg; generic type LABEL_TYPE is private; -- Type for labels stored in the tree. type VALUE_TYPE is private; -- Type for values stored in the tree. with function Difference (P, Q: LABEL_TYPE) return INTEGER is <>; -- Must return a value > 0 if P > Q, 0 if P = Q, and less than -- zero otherwise, where P and Q are labels. package Labeled_Binary_Trees_Pkg is --| Purpose --| This package provides labeled binary trees, which are the same as --| unlabeled binary trees except that when searching for or inserting --| a value into the tree, only the label field is compared. --| --| Initialization Exceptions (none) --| --| Notes --| USAGE: (See Overview of Binary_Trees_Package) --| --| PERFORMANCE: (See Overview of Binary_Trees_Package) --| --| Modifications --| Author: Bill Toscano and Michael Gordon, Intermetrics, Inc. -- This should be private (but cannot be) type LABEL_VALUE_PAIR is record Label : LABEL_TYPE; Value : VALUE_TYPE; end record; function LV_Differ (P, Q: LABEL_VALUE_PAIR) return INTEGER; package LVT is new Binary_Trees_Pkg (LABEL_VALUE_PAIR, LV_Differ); -- Exceptions -- Duplicate_Value: exception renames LVT.Duplicate_Value; -- Raised on attempt to insert a duplicate label into a tree. Not_Found: exception renames LVT.Not_Found; -- Raised on attempt to find a label that is not in a tree. No_More: exception renames LVT.No_More; -- Raised on attempt to bump an iterator that has already scanned the -- entire tree. Out_Of_Order: exception renames LVT.Out_Of_Order; -- Raised if a problem in the ordering of a tree is detected. Invalid_Tree: exception renames LVT.Invalid_Tree; -- Value is not a tree or was not properly initialized. -- Types -- subtype SCAN_KIND is LVT.SCAN_KIND; --? function InOrder return LVT.Scan_Kind renames LVT.InOrder; InOrder : constant SCAN_KIND := LVT.InOrder; PreOrder : constant SCAN_KIND := LVT.PreOrder; PostOrder : constant SCAN_KIND := LVT.PostOrder; -- is (inorder, preorder, postorder); -- Used to specify the order in which values should be scanned from a tree: -- -- inorder: Left, Node, Right (nodes visited in increasing order) -- preorder: Node, Left, Right (top down) -- postorder: Left, Right, Node (bottom up) subtype TREE is LVT.TREE; subtype ITERATOR is LVT.ITERATOR; -- Operations -- -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.CREATE . SPEC -- . . -- ........................................................ Function Create return TREE renames LVT.Create; --| Purpose --| Create and return an empty tree. Note that this allocates --| a small amount of storage which can only be reclaimed through --| a call to Destroy. --| --| Exceptions (none) --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.INSERT . SPEC -- . . -- ........................................................ Procedure Insert (L: LABEL_TYPE; V: VALUE_TYPE; T: TREE); --| Purpose --| Insert (L, V) into T in the proper place. If a label equal --| to L (according to the Difference function) is already contained --| in the tree, the exception Duplicate_Label is raised. --| Caution: Since this package does not attempt to balance trees as --| values are inserted, it is important to remember that inserting --| labels in sorted order will create a degenerate tree, where search --| and insertion is proportional to the N instead of to Log N. If --| this pattern is common, use the Balanced_Tree function below. --| --| Exceptions --| Duplicate_Value --| Invalid_Tree --| --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.INSERT_IF_NOT_FOUND . SPEC -- . . -- ........................................................ procedure Insert_if_not_Found (L : LABEL_TYPE; V : VALUE_TYPE; T : TREE; Found : out BOOLEAN; Duplicate : out VALUE_TYPE); --| Purpose --| Insert V into T in the proper place. If a value equal --| to V (according to the Difference function) is already contained --| in the tree, Found will be True and Duplicate will be the duplicate --| value. This might be a sequence of values with the same key, and --| V can then be added to the sequence. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.REPLACE_IF_FOUND . SPEC -- . . -- ........................................................ procedure Replace_if_Found (L : LABEL_TYPE; V : VALUE_TYPE; T : TREE; Found : out BOOLEAN; Old_Value : out VALUE_TYPE); --| Purpose --| Search for L in T. If found, replace the old value with V, --| and return Found => True, Old_Value => the old value. Otherwise, --| simply insert the L, V pair into T and return Found => False. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.DESTROY . SPEC -- . . -- ........................................................ procedure Destroy (T: in out TREE) renames LVT.Destroy; --| Purpose --| The space allocated to T is reclaimed. The space occupied by --| the values stored in T is not however, recovered. --| --| Exceptions (none) --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.DESTROY_DEEP . SPEC -- . . -- ........................................................ generic with procedure Free_Value (V: in out VALUE_TYPE) is <>; with procedure Free_Label (L: in out LABEL_TYPE) is <>; procedure Destroy_Deep (T: in out TREE); --| Purpose --| The space allocated to T is reclaimed. The values and --| labels stored it T are reclaimed using Free_Label and --| Free_Value, and the tree nodes themselves --| are then reclaimed (in a single walk of the tree). --| --| Exceptions (none) --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.BALANCED_TREE . SPEC -- . . -- ........................................................ generic with procedure Next_Pair (L: in out LABEL_TYPE; V: in out VALUE_TYPE) is <>; -- Each call to this procedure should return the next (Label, Value) -- pair to be -- inserted into the balanced tree being created. If necessary, -- this function should check that each value is greater than the -- previous one, and raise Out_of_Order if necessary. If values -- are not returned in strictly increasing order, the results are -- unpredictable. function Balanced_Tree (Count: NATURAL) return TREE; --| Purpose --| Create a balanced tree by calling next_Pair Count times. --| Each time Next_Pair is called, it must return a label that compares --| greater than the preceeding label. This function is useful for balancing --| an existing tree (next_Pair iterates over the unbalanced tree) or --| for creating a balanced tree when reading data from a file which is --| already sorted. --| --| Exceptions (none) --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.COPY_TREE . SPEC -- . . -- ........................................................ generic with function Copy_Label (L: LABEL_TYPE) return LABEL_TYPE is <>; with function Copy_Value (V: VALUE_TYPE) return VALUE_TYPE is <>; -- This function is called to copy a value from the old tree to the -- new tree. Function Copy_Tree (T: TREE) return TREE; --| Purpose --| Create a balanced tree that is a copy of the tree T. --| The exception Invalid_Tree is raised if T is not a valid tree. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.IS_EMPTY . SPEC -- . . -- ........................................................ function Is_Empty (T: TREE) return BOOLEAN renames LVT.Is_Empty; --| Purpose --| Return TRUE iff T is an empty tree or if T was not initialized. --| --| Exceptions (none) --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.FIND . SPEC -- . . -- ........................................................ Function Find (L: LABEL_TYPE; T: TREE) return VALUE_TYPE; --| Purpose --| Search T for a label that matches L. The corresponding value --| is returned. If no matching label is found, the exception Not_Found --| is raised. --| --| Exceptions --| Not_Found --| Invalid_Tree --| --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.FIND . SPEC -- . . -- ........................................................ Procedure Find (L : LABEL_TYPE; T : TREE; Found : out BOOLEAN; Match : out VALUE_TYPE); --| Purpose --| Search T for a label that matches L. On return, if Found is --| TRUE then the corresponding value is returned in Match. Otherwise, --| Found is FALSE and Match is undefined. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.IS_FOUND . SPEC -- . . -- ........................................................ function Is_Found (L: LABEL_TYPE; T: TREE) return BOOLEAN; --| Purpose --| Return TRUE iff L is found in T. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.SIZE . SPEC -- . . -- ........................................................ function Size (T: TREE) return NATURAL renames LVT.Size; --| Purpose --| Return the number of values stored in T. --| --| Exceptions (none) --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.VISIT . SPEC -- . . -- ........................................................ generic with procedure Process(L: LABEL_TYPE; V: VALUE_TYPE) is <>; procedure Visit (T : TREE; Order : SCAN_KIND); --| Purpose --| Invoke Process(V) for each value V in T. The nodes are visited --| in the order specified by Order. Although more limited than using --| an iterator, this function is also much faster. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.MAKE_ITER . SPEC -- . . -- ........................................................ function Make_Iter (T: TREE) return ITERATOR renames LVT.Make_Iter; --| Purpose --| Create an iterator over a tree. --| --| Exceptions --| Invalid_Tree --| --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.MORE . SPEC -- . . -- ........................................................ function More (I: ITERATOR) return BOOLEAN renames LVT.More; --| Purpose --| Return TRUE iff unscanned nodes remain in the tree being --| scanned by I. --| --| Exceptions (none) --| Notes (none) -- ........................................................ -- . . -- . LABELED_BINARY_TREES_PKG.NEXT . SPEC -- . . -- ........................................................ procedure Next (I: in out ITERATOR; L: out LABEL_TYPE; V: out VALUE_TYPE); --| Purpose --| Return the next value in the tree being scanned by I. --| The exception No_More is raised if there are no more values to scan. --| --| Exceptions --| No_More --| --| Notes (none) end Labeled_Binary_Trees_Pkg; --:::::::::: --ordset.spc --:::::::::: -- **************************************************** -- * * -- * ORDEREDSETS * SPEC -- * * -- **************************************************** with BinaryTrees; generic type ITEMTYPE is private; with function "<" (X, Y : in ITEMTYPE) return BOOLEAN; package OrderedSets is --| Purpose --| 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. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Bill Toscano and Michael Gordon, Intermetrics type SET is private; type SETITER is private; -- ..................................................... -- . . -- . ORDEREDSETS.CARDINALITY . SPEC -- . . -- ..................................................... function Cardinality (S : in SET) return NATURAL; --| Purpose --| Return the number of members in the set. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . ORDEREDSETS.CREATE . SPEC -- . . -- ..................................................... function Create return SET; --| Purpose --| Return the empty set. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . ORDEREDSETS.DESTROY . SPEC -- . . -- ..................................................... procedure Destroy (S : in out SET); --| Purpose --| Destroy a set and return its space. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . ORDEREDSETS.GETCOUNT . SPEC -- . . -- ..................................................... function GetCount (I : in SETITER) return NATURAL; --| Purpose --| Returns the count associated with the member corresponding to the --| current interator I. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . ORDEREDSETS.INSERT . SPEC -- . . -- ..................................................... procedure Insert (M : in ITEMTYPE; S : in out SET); --| Purpose --| Insert a member M into set S. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . ORDEREDSETS.MAKESETITER . SPEC -- . . -- ..................................................... function MakeSetIter (S : in SET) return SETITER; --| Purpose --| Prepares a user for an iteration operation by returning --| a SetIter. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . ORDEREDSETS.MORE . SPEC -- . . -- ..................................................... function More (I : in SETITER) return BOOLEAN; --| Purpose --| Returns TRUE if there are more elements in the set --| to iterate over. --| --| Exceptions (none) --| Notes (none) -- ..................................................... -- . . -- . ORDEREDSETS.NEXT . SPEC -- . . -- ..................................................... procedure Next (I : in out SETITER; M : out ITEMTYPE); --| Purpose --| Returns the current member in the iteration and increments --| the iterator. --| --| Exceptions (none) --| Notes (none) private type MEMBER is record Info : ITEMTYPE; Count : NATURAL; end record; function "<" (X: in MEMBER; Y: in MEMBER) return BOOLEAN; package TreePkg is new BinaryTrees (ITEMTYPE => MEMBER, "<" => "<"); type SET is record SetRep :TreePkg.TREE; end record; type SETITER is record Place : TreePkg.TREEITER; Count : NATURAL; end record; end OrderedSets; --:::::::::: --string.spc --:::::::::: -- ********************************************** -- * * -- * STRING_PKG * SPEC -- * * -- ********************************************** package String_Pkg is --| Purpose --| Package string_pkg exports an abstract data type, string_type. A --| string_type value is a sequence of characters. The values have arbitrary --| length. For a value, s, with length, l, the individual characters are --| numbered from 1 to l. These values are immutable; characters cannot be --| replaced or appended in a destructive fashion. --| --| In the documentation for this package, we are careful to distinguish --| between string_type objects, which are Ada objects in the usual sense, --| and string_type values, the members of this data abstraction as described --| above. A string_type value is said to be associated with, or bound to, --| a string_type object after an assignment (:=) operation. --| --| The operations provided in this package fall into three categories: --| --| 1. Constructors: These functions typically take one or more string_type --| objects as arguments. They work with the values associated with --| these objects, and return new string_type values according to --| specification. By a slight abuse of language, we will sometimes --| coerce from string_type objects to values for ease in description. --| --| 2. Heap Management: --| These operations (make_persistent, flush, mark, release) control the --| management of heap space. Because string_type values are --| allocated on the heap, and the type is not limited, it is necessary --| for a user to assume some responsibility for garbage collection. --| String_type is not limited because of the convenience of --| the assignment operation, and the usefulness of being able to --| instantiate generic units that contain private type formals. --| ** Important: To use this package properly, it is necessary to read --| the descriptions of the operations in this section. --| --| 3. Queries: These functions return information about the values --| that are associated with the argument objects. The same conventions --| for description of operations used in (1) is adopted. --| --| A note about design decisions... The decision to not make the type --| limited causes two operations to be carried over from the representation. --| These are the assignment operation, :=, and the "equality" operator, "=". --| See the discussion at the beginning of the Heap Management section for a --| discussion of :=. --| See the spec for the first of the equal functions for a discussion of "=". --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Programmer: Ron Kownacki, Intermetrics type STRING_TYPE is private; type COMPARISON_OPTION is (CASE_SENSITIVE, CASE_INSENSITIVE); -- Used for equal, "<" and "<=" functions. If the comparison_option -- is case_sensitive, then a straightforward comparison of values -- is performed. If the option is case_insensitive, then comparison -- between the arguments is performed after first normalizing them to -- lower case. Bounds: exception; -- Raised on index out of bounds. Any_Empty: exception; -- Raised on incorrect use of match_any. Illegal_Alloc: exception; -- Raised by value creating operations. Illegal_Dealloc: exception; -- Raised by release. -- Constructors: -- ............................................... -- . . -- . STRING_PKG.CREATE . SPEC -- . . -- ............................................... function Create (S: in STRING) return STRING_TYPE; --| Purpose --| Return a value consisting of the sequence of characters in s. --| Sometimes useful for array or record aggregates. --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.& . SPEC -- . . -- ............................................... function "&" (S1, S2: in STRING_TYPE) return STRING_TYPE; --| Purpose --| Return the concatenation of s1 and s2. --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.& . SPEC -- . . -- ............................................... function "&" (S1: in STRING_TYPE; S2: in STRING) return STRING_TYPE; --| Purpose --| Return the concatenation of s1 and create(s2). --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.& . SPEC -- . . -- ............................................... function "&" (S1: in STRING; S2: in STRING_TYPE) return STRING_TYPE; --| Purpose --| Return the concatenation of create(s1) and s2. --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.SUBSTR . SPEC -- . . -- ............................................... function Substr (S : in STRING_TYPE; I : in POSITIVE; Len : in NATURAL) return STRING_TYPE; --| Purpose --| Return the substring, of specified length, that occurs in s at --| position i. If len = 0, then returns the empty value. --| Otherwise, raises bounds if either i or (i + len - 1) --| is not in 1..length(s). --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.SPLICE . SPEC -- . . -- ............................................... function Splice (S : in STRING_TYPE; I : in POSITIVE; Len : in NATURAL) return STRING_TYPE; --| Purpose --| Let s be the string, abc, where a, b and c are substrings. If --| substr(s, i, length(b)) = b, for some i in 1..length(s), then --| splice(s, i, length(b)) = ac. --| Returns a value equal to s if len = 0. Otherwise, raises bounds if --| either i or (i + len - 1) is not in 1..length(s). --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.INSERT . SPEC -- . . -- ............................................... function Insert (S1, S2: in STRING_TYPE; I: in POSITIVE) return STRING_TYPE; --| Purpose --| Return substr(s1, 1, i - 1) & s2 & substr(s1, i, length(s1)). --| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no --| exception is raised by insert. --| Raises bounds if i is not in 1..length(s1) + 1. --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| bounds --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.INSERT . SPEC -- . . -- ............................................... function Insert (S1 : in STRING_TYPE; S2 : in STRING; I : in POSITIVE) return STRING_TYPE; --| Purpose --| Return substr(s1, 1, i - 1) & s2 & substr(s1, i, length(s1)). --| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no --| exception is raised by insert. --| Raises bounds if i is not in 1..length(s1) + 1. --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| bounds --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.INSERT . SPEC -- . . -- ............................................... function Insert (S1 : in STRING; S2 : in STRING_TYPE; I : in POSITIVE) return STRING_TYPE; --| Purpose --| Return s1(s1'first..i - 1) & s2 & s1(i..s1'last). --| equal(splice(insert(s1, s2, i), i, length(s2)), s1) holds if no --| exception is raised by insert. --| Raises bounds if i is not in s'first..s'last + 1. --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| bounds --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.LOWER . SPEC -- . . -- ............................................... function Lower (S: in STRING) return STRING_TYPE; --| Purpose --| Return a value that contains exactly those characters in s with --| the exception that all upper case characters are replaced by their --| lower case counterparts. --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.LOWER . SPEC -- . . -- ............................................... function Lower (S: in STRING_TYPE) return STRING_TYPE; --| Purpose --| Return a value that is a copy of s with the exception that all --| upper case characters are replaced by their lower case counterparts. --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.UPPER . SPEC -- . . -- ............................................... function Upper (S: in STRING) return STRING_TYPE; --| Purpose --| Return a value that contains exactly those characters in s with --| the exception that all lower case characters are replaced by their --| upper case counterparts. --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| illegal_alloc --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.UPPER . SPEC -- . . -- ............................................... function Upper (S: in STRING_TYPE) return STRING_TYPE; --| Purpose --| Return a value that is a copy of s with the exception that all --| lower case characters are replaced by their upper case counterparts. --| Raises illegal_alloc if string space has been improperly --| released. (See procedures mark/release.) --| --| Exceptions --| illegal_alloc --| --| Notes (none) -- Heap Management (including object/value binding): -- -- Two forms of heap management are provided. The general scheme is to "mark" -- the current state of heap usage, and to "release" in order to reclaim all -- space that has been used since the last mark. However, this alone is -- insufficient because it is frequently desirable for objects to remain -- associated with values for longer periods of time, and this may come into -- conflict with the need to clean up after a period of "string hacking." -- To deal with this problem, we introduce the notions of "persistent" and -- "nonpersistent" values. -- -- The nonpersistent values are those that are generated by the constructors -- in the previous section. These are claimed by the release procedure. -- Persistent values are generated by the two make_persistent functions -- described below. These values must be disposed of individually by means of -- the flush procedure. -- -- This allows a description of the meaning of the ":=" operation. For a -- statement of the form, s := expr, where expr is a STRING_TYPE expression, -- the result is that the value denoted/created by expr becomes bound to the -- the object, s. Assignment in no way affects the persistence of the value. -- If expr happens to be an object, then the value associated with it will be -- shared. Ideally, this sharing would not be visible, since values are -- immutable. However, the sharing may be visible because of the memory -- management, as described below. Programs which depend on such sharing are -- erroneous. -- ............................................... -- . . -- . STRING_PKG.MAKE_PERSISTENT . SPEC -- . . -- ............................................... function Make_Persistent (S: in STRING_TYPE) return STRING_TYPE; --| Purpose --| Returns a persistent value, v, containing exactly those characters in --| value(s). The value v will not be claimed by any subsequent release. --| Only an invocation of flush will claim v. After such a claiming --| invocation of flush, the use (other than :=) of any other object to --| which v was bound is erroneous, and program_error may be raised for --| such a use. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.MAKE_PERSISTENT . SPEC -- . . -- ............................................... function Make_Persistent (S: in STRING) return STRING_TYPE; --| Purpose --| Returns a persistent value, v, containing exactly those chars in s. --| The value v will not be claimed by any subsequent release. --| Only an invocation of flush will reclaim v. After such a claiming --| invocation of flush, the use (other than :=) of any other object to --| which v was bound is erroneous, and program_error may be raised for --| such a use. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.FLUSH . SPEC -- . . -- ............................................... procedure Flush (S: in out STRING_TYPE); --| Purpose --| Return heap space used by the value associated with s, if any, to --| the heap. s becomes associated with the empty value. After an --| invocation of flush claims the value, v, then any use (other than :=) --| of an object to which v was bound is erroneous, and program_error --| may be raised for such a use. --| --| This operation should be used only for persistent values. The mark --| and release operations are used to deallocate space consumed by other --| values. For example, flushing a nonpersistent value implies that a --| release that tries to claim this value will be erroneous, and --| program_error may be raised for such a use. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.MARK . SPEC -- . . -- ............................................... procedure Mark; --| Purpose --| Marks the current state of heap usage for use by release. --| An implicit mark is performed at the beginning of program execution. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.RELEASE . SPEC -- . . -- ............................................... procedure Release; --| Purpose --| Releases all heap space used by nonpersistent values that have been --| allocated since the last mark. The values that are claimed include --| those bound to objects as well as those produced and discarded during --| the course of general "string hacking." If an invocation of release --| claims a value, v, then any subsequent use (other than :=) of any --| other object to which v is bound is erroneous, and program_error may --| be raised for such a use. --| --| Raises illegal_dealloc if the invocation of release does not balance --| an invocation of mark. It is permissible to match the implicit --| initial invocation of mark. However, subsequent invocations of --| constructors will raise the illegal_alloc exception until an --| additional mark is performed. (Anyway, there is no good reason to --| do this.) In any case, a number of releases matching the number of --| currently active marks is implicitly performed at the end of program --| execution. --| --| Good citizens generally perform their own marks and releases --| explicitly. Extensive string hacking without cleaning up will --| cause your program to run very slowly, since the heap manager will --| be forced to look hard for chunks of space to allocate. --| --| Exceptions --| illegal_dealloc --| --| Notes (none) -- Queries: -- ............................................... -- . . -- . STRING_PKG.IS_EMPTY . SPEC -- . . -- ............................................... function Is_Empty (S: in STRING_TYPE) return BOOLEAN; --| Purpose --| Return TRUE iff s is the empty sequence of characters. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.LENGTH . SPEC -- . . -- ............................................... function Length (S: in STRING_TYPE) return NATURAL; --| Purpose --| Return number of characters in s. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.VALUE . SPEC -- . . -- ............................................... function Value (S: in STRING_TYPE) return STRING; --| Purpose --| Return a string, s2, that contains the same characters that s --| contains. The properties, s2'first = 1 and s2'last = length(s), --| are satisfied. This implies that, for a given string, s3, --| value(create(s3))'first may not equal s3'first, even though --| value(create(s3)) = s3 holds. Thus, "content equality" applies --| although the string objects may be distinguished by the use of --| the array attributes. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.FETCH . SPEC -- . . -- ............................................... function Fetch (S: in STRING_TYPE; I: in POSITIVE) return CHARACTER; --| Purpose --| Return the ith character in s. Characters are numbered from --| 1 to length(s). Raises bounds if i not in 1..length(s). --| --| Exceptions --| bounds --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.SET_COMPARISON_OPTION . SPEC -- . . -- ............................................... procedure Set_Comparison_Option (Choice: in COMPARISON_OPTION); --| Purpose --| Set the comparison option for equal, "<" and "<=" (as described --| above) to the given choice. The initial setting is case_sensitive. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.GET_COMPARISON_OPTION . SPEC -- . . -- ............................................... function Get_Comparison_Option return COMPARISON_OPTION; --| Purpose --| Return the current comparison_option setting. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.EQUAL . SPEC -- . . -- ............................................... function Equal (S1, S2: in STRING_TYPE) return BOOLEAN; --| Purpose --| Value equality relation; return true iff length(s1) = length(s2) --| and, for all i in 1..length(s1), fetch(s1, i) = fetch(s2, i). --| (If the comparison_option is currently case_insensitive, then --| lower(s1) and lower(s2) are used instead.) --| --| Exceptions (none) --| --| Notes --| The "=" operation is carried over from the representation. --| It allows one to distinguish among the heap addresses of --| STRING_TYPE values. Even "equal" values under case_sensitive --| comparison may not be "=", although s1 = s2 implies equal(s1, s2). --| There is no reason to use "=". -- ............................................... -- . . -- . STRING_PKG.EQUAL . SPEC -- . . -- ............................................... function Equal (S1: in STRING_TYPE; S2: in STRING) return BOOLEAN; --| Purpose --| Return equal(s1, create(s2)). --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.EQUAL . SPEC -- . . -- ............................................... function Equal (S1: in STRING; S2: in STRING_TYPE) return BOOLEAN; --| Purpose --| Return equal(create(s1), s2). --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG."<" . SPEC -- . . -- ............................................... function "<" (S1, S2: in STRING_TYPE) return BOOLEAN; --| Purpose --| Lexicographic comparison according to the current comparison_option; --| return value(s1) < value(s2). --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG."<" . SPEC -- . . -- ............................................... function "<" (S1: in STRING_TYPE; S2: in STRING) return BOOLEAN; --| Purpose --| Lexicographic comparison according to the current comparison_option; --| return value(s1) < s2. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG."<" . SPEC -- . . -- ............................................... function "<" (S1: in STRING; S2: in STRING_TYPE) return BOOLEAN; --| Purpose --| Lexicographic comparison according to the current comparison_option; --| return s1 < value(s2). --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG."<=" . SPEC -- . . -- ............................................... function "<=" (S1, S2: in STRING_TYPE) return BOOLEAN; --| Purpose --| Lexicographic comparison according to the current comparison_option; --| return value(s1) <= value(s2). --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG."<=" . SPEC -- . . -- ............................................... function "<=" (S1: in STRING_TYPE; S2: in STRING) return BOOLEAN; --| Purpose --| Lexicographic comparison according to the current comparison_option; --| return value(s1) <= s2. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG."<=" . SPEC -- . . -- ............................................... function "<=" (S1: in STRING; S2: in STRING_TYPE) return BOOLEAN; --| Purpose --| Lexicographic comparison according to the current comparison_option; --| return s1 <= value(s2). --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.MATCH_C . SPEC -- . . -- ............................................... function Match_C (S : in STRING_TYPE; C : in CHARACTER; Start : in POSITIVE := 1) return NATURAL; --| Purpose --| Return the minimum index, i in start..length(s), such that --| fetch(s, i) = c. Returns 0 if no such i exists, --| including the case where is_empty(s). --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.MATCH_NOT_C . SPEC -- . . -- ............................................... function Match_Not_C (S : in STRING_TYPE; C : in CHARACTER; Start : in POSITIVE := 1) return NATURAL; --| Purpose --| Return the minimum index, i in start..length(s), such that --| fetch(s, i) /= c. Returns 0 if no such i exists, --| including the case where is_empty(s). --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.MATCH_S . SPEC -- . . -- ............................................... function Match_S (S1, S2: in STRING_TYPE; Start: in POSITIVE := 1) return natural; --| Purpose --| Return the minimum index, i, in start..length(s1), such that, --| for all j in 1..length(s2), fetch(s2, j) = fetch(s1, i + j - 1). --| This is the position of the substring, s2, in s1. --| Returns 0 if no such i exists, including the cases --| where is_empty(s1) or is_empty(s2). --| Note that equal(substr(s1, match_s(s1, s2, i), length(s2)), s2) --| holds, providing that match_s does not raise an exception. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.MATCH_S . SPEC -- . . -- ............................................... function Match_S (S1 : in STRING_TYPE; S2 : in STRING; Start : in POSITIVE := 1) return NATURAL; --| Purpose --| Return the minimum index, i, in start..length(s1), such that, --| for all j in s2'range, s2(j) = fetch(s1, i + j - 1). --| This is the position of the substring, s2, in s1. --| Returns 0 if no such i exists, including the cases --| where is_empty(s1) or s2 = "". --| Note that equal(substr(s1, match_s(s1, s2, i), s2'length), s2) --| holds, providing that match_s does not raise an exception. --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.MATCH_ANY . SPEC -- . . -- ............................................... function Match_Any (S, Any : in STRING_TYPE; Start : in POSITIVE := 1) return NATURAL; --| Purpose --| Return the minimum index, i in start..length(s), such that --| fetch(s, i) = fetch(any, j), for some j in 1..length(any). --| Raises any_empty if is_empty(any). --| Otherwise, returns 0 if no such i exists, including the case --| where is_empty(s). --| --| Exceptions --| any_empty --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.MATCH_ANY . SPEC -- . . -- ............................................... function Match_Any (S : in STRING_TYPE; Any : in STRING; Start : in POSITIVE := 1) return NATURAL; --| Purpose --| Return the minimum index, i, in start..length(s), such that --| fetch(s, i) = any(j), for some j in any'range. --| Raises any_empty if any = "". --| Otherwise, returns 0 if no such i exists, including the case --| where is_empty(s). --| --| Exceptions --| any_empty --| --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.MATCH_NONE . SPEC -- . . -- ............................................... function Match_None (S, None : in STRING_TYPE; Start : in POSITIVE := 1) return NATURAL; --| Purpose --| Return the minimum index, i in start..length(s), such that --| fetch(s, i) /= fetch(none, j) for each j in 1..length(none). --| If (not is_empty(s)) and is_empty(none), then i is 1. --| Returns 0 if no such i exists, including the case --| where is_empty(s). --| --| Exceptions (none) --| Notes (none) -- ............................................... -- . . -- . STRING_PKG.MATCH_NONE . SPEC -- . . -- ............................................... function Match_None (S : in STRING_TYPE; None : in STRING; Start : in POSITIVE := 1) return NATURAL; --| Purpose --| Return the minimum index, i in start..length(s), such that --| fetch(s, i) /= none(j) for each j in none'range. --| If not is_empty(s) and none = "", then i is 1. --| Returns 0 if no such i exists, including the case --| where is_empty(s). --| --| Exceptions (none) --| Notes (none) private type STRING_TYPE is access STRING; -- Abstract data type, STRING_TYPE, is a constant sequence of chars -- of arbitrary length. Representation type is access string. -- It is important to distinguish between an object of the rep type -- and its value; for an object, r, val(r) denotes the value. -- -- Representation Invariant: I: rep --> boolean -- I(r: rep) = (val(r) = null) or else -- (val(r).all'first = 1 & -- val(r).all'last >= 0 & -- (for all r2, val(r) = val(r2) /= null => r is r2)) -- -- Abstraction Function: A: rep --> STRING_TYPE -- A(r: rep) = if r = null then -- the empty sequence -- elsif r'last = 0 then -- the empty sequence -- else -- the sequence consisting of r(1),...,r(r'last). end String_Pkg; --:::::::::: --sscan.spc --:::::::::: -- ********************************************** -- * * -- * STRING_SCANNER * SPEC -- * * -- ********************************************** with String_Pkg; use String_Pkg; package String_Scanner is --| Purpose --| Functions for scanning tokens from strings. --| --| This package provides a set of functions used to scan tokens from --| strings. After the function make_Scanner is called to convert a string --| into a string Scanner, the rest of the functions may be called to scan --| various tokens from the string. --| --| Initialization Exceptions (none) --| Notes (none) --| Modifications --| Source: Bill Toscano and Michael Gordon, Intermetrics type SCANNER is private; Out_Of_Bounds : exception; -- Raised when a operation is attempted on a -- Scanner that has passed the end Scanner_Already_Marked : exception; -- Raised when a Mark is attemped on a Scanner -- that has already been marked -- .............................................. -- . . -- . STRING_SCANNER.MAKE_SCANNER . SPEC -- . . -- .............................................. function Make_Scanner (S : in STRING_TYPE) return SCANNER; --| Purpose --| Construct a Scanner from S. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.DESTROY_SCANNER . SPEC -- . . -- .............................................. procedure Destroy_Scanner (T : in out SCANNER); --| Purpose --| Free space occupied by the Scanner. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.MORE . SPEC -- . . -- .............................................. function More (T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff additional characters remain to be scanned. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.FORWARD . SPEC -- . . -- .............................................. procedure Forward (T : in SCANNER); --| Purpose --| Advance the scanner position. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.BACKWARD . SPEC -- . . -- .............................................. procedure Backward (T : in SCANNER); --| Purpose --| Bump back the scanner position. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.GET . SPEC -- . . -- .............................................. function Get (T : in SCANNER) return CHARACTER; --| Purpose --| Return character at the current Scanner position. --| The scanner position remains unchanged. --| --| Exceptions --| Out_Of_Bounds --| --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.NEXT . SPEC -- . . -- .............................................. procedure Next (T : in SCANNER; C : out CHARACTER); --| Purpose --| Return character at the current Scanner position and update --| the position. --| --| Exceptions --| Out_Of_Bounds --| --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.POSITION . SPEC -- . . -- .............................................. function Position (T : in SCANNER) return POSITIVE; --| Purpose --| Return a positive integer indicating the current Scanner position, --| --| Exceptions --| Out_Of_Bounds --| --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.GET_STRING . SPEC -- . . -- .............................................. function Get_String (T : in SCANNER) return STRING_TYPE; --| Purpose --| Return a String_Type corresponding to the contents of the Scanner --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.GET_REMAINDER . SPEC -- . . -- .............................................. function Get_Remainder (T : in SCANNER) return STRING_TYPE; --| Purpose --| Return a String_Type starting at the current index of the Scanner --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.MARK . SPEC -- . . -- .............................................. procedure Mark (T : in SCANNER); --| Purpose --| Mark the current index for possible future use. --| --| Exceptions --| Scanner_Already_Marked --| --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.RESTORE . SPEC -- . . -- .............................................. procedure Restore (T : in SCANNER); --| Purpose --| Restore the index to the previously marked value --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_WORD . SPEC -- . . -- .............................................. function Is_Word (T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff Scanner is at the start of a word. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_WORD . SPEC -- . . -- .............................................. procedure Scan_word (T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a sequence of non-blank --| characters. If at least one is found, return Found => TRUE, --| Result => <the characters>. --| Otherwise return Found => FALSE and Result is unpredictable. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_NUMBER . SPEC -- . . -- .............................................. function Is_Number (T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff Scan_Number would return a non-null string (Scanner is --| at a decimal digit). --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_NUMBER . SPEC -- . . -- .............................................. procedure Scan_Number (T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a sequence of digits. --| If at least one is found, return Found => TRUE, Result => <the digits>. --| Otherwise return Found => FALSE and Result is unpredictable. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_NUMBER . SPEC -- . . -- .............................................. procedure Scan_Number (T : in SCANNER; Found : out BOOLEAN; Result : out INTEGER; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a sequence of digits. --| If at least one is found, return Found => TRUE, Result => <the digits>. --| Otherwise return Found => FALSE and Result is unpredictable. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_SIGNED_NUMBER . SPEC -- . . -- .............................................. function Is_Signed_Number (T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff Scan_Signed_Number would return a non-null --| string and Scanner is at a decimal digit or sign (+/-). --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_SIGNED_NUMBER . SPEC -- . . -- .............................................. procedure Scan_Signed_Number (T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a sequence of digits preceeded with optional sign. --| If at least one digit is found, return Found => TRUE, --| Result => <the digits>. --| Otherwise return Found => FALSE and Result is unpredictable. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_SIGNED_NUMBER . SPEC -- . . -- .............................................. procedure Scan_Signed_Number (T : in SCANNER; Found : out BOOLEAN; Result : out INTEGER; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a sequence of digits preceeded with optional sign. --| If at least one digit is found, return Found => TRUE, --| Result => <the digits>. --| Otherwise return Found => FALSE and Result is unpredictable. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_SPACE . SPEC -- . . -- .............................................. function Is_Space (T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff Scan_Space would return a non-null string. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_SPACE . SPEC -- . . -- .............................................. procedure Scan_Space (T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE); --| Purpose --| Scan T past all white space (spaces --| and tabs. If at least one is found, return Found => TRUE, --| Result => <the characters>. --| Otherwise return Found => FALSE and Result is unpredictable. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SKIP_SPACE . SPEC -- . . -- .............................................. procedure Skip_Space (T : in SCANNER); --| Purpose --| Scan T past all white space (spaces and tabs). --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_ADA_ID . SPEC -- . . -- .............................................. function Is_Ada_Id (T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff Scan_Ada_Id would return a non-null string. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_ADA_ID . SPEC -- . . -- .............................................. procedure Scan_Ada_Id (T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a valid Ada identifier. --| If one is found, return Found => TRUE, Result => <the characters>. --| Otherwise return Found => FALSE and Result is unpredictable. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_QUOTED . SPEC -- . . -- .............................................. function Is_Quoted (T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff T is at a quoted string (eg. ... "Hello" ...). --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_QUOTED . SPEC -- . . -- .............................................. procedure Scan_Quoted (T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan at T for an opening quote --| followed by a sequence of characters and ending with a closing --| quote. If successful, return Found => TRUE, Result => <the characters>. --| Otherwise return Found => FALSE and Result is unpredictable. --| A pair of quotes within the quoted string is converted to a single quote. --| The outer quotes are stripped. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_ENCLOSED . SPEC -- . . -- .............................................. function Is_Enclosed (B : in CHARACTER; E : in CHARACTER; T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff T as encosed by B and E (eg. ... [ABC] ...). --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_ENCLOSED . SPEC -- . . -- .............................................. procedure Scan_Enclosed (B : in CHARACTER; E : in CHARACTER; T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan at T for an enclosing character --| followed by a sequence of characters and ending with an enclosing character. --| If successful, return Found => TRUE, Result => <the characters>. --| Otherwise return Found => FALSE and Result is unpredictable. --| The enclosing characters are stripped. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_SEQUENCE . SPEC -- . . -- .............................................. function Is_Sequence (Chars : in STRING_TYPE; T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff T is at some character of Chars. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_SEQUENCE . SPEC -- . . -- .............................................. function Is_Sequence (Chars : in STRING; T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff T is at some character of Chars. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_SEQUENCE . SPEC -- . . -- .............................................. procedure Scan_Sequence (Chars : in STRING_TYPE; T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a sequence of characters C such that C appears in --| Char. If at least one is found, return Found => TRUE, --| Result => <the characters>. --| Otherwise return Found => FALSE and Result is unpredictable. --| Skip means to skip white characters before scanning. --| --| Exceptions (none) --| --| Notes --| Scan_Sequence("0123456789", S, Index, Found, Result) --| is equivalent to Scan_Number(S, Index, Found, Result) --| but is less efficient. -- .............................................. -- . . -- . STRING_SCANNER.SCAN_SEQUENCE . SPEC -- . . -- .............................................. procedure Scan_Sequence (Chars : in STRING; T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a sequence of characters C such that C appears in --| Char. If at least one is found, return Found => TRUE, --| Result => <the characters>. --| Otherwise return Found => FALSE and Result is unpredictable. --| Skip means to skip white characters before scanning. --| --| Exceptions (none) --| --| Notes --| Scan_Sequence("0123456789", S, Index, Found, Result) --| is equivalent to Scan_Number(S, Index, Found, Result) --| but is less efficient. -- .............................................. -- . . -- . STRING_SCANNER.IS_NOT_SEQUENCE . SPEC -- . . -- .............................................. function Is_Not_Sequence (Chars : in STRING_TYPE; T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff T is not at some character of Chars. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_NOT_SEQUENCE . SPEC -- . . -- .............................................. function Is_Not_Sequence (Chars : in STRING; T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff T is not at some character of Chars. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_NOT_SEQUENCE . SPEC -- . . -- .............................................. procedure Scan_Not_Sequence (Chars : in STRING_TYPE; T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a sequence of characters C such that C does not appear --| in Chars. If at least one such C is found, return Found => TRUE, --| Result => <the characters>. --| Otherwise return Found => FALSE and Result is unpredictable. --| Skip means to skip white characters before scanning. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_NOT_SEQUENCE . SPEC -- . . -- .............................................. procedure Scan_Not_Sequence (Chars : in STRING; T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a sequence of characters C such that C does not appear --| in Chars. If at least one such C is found, return Found => TRUE, --| Result => <the characters>. --| Otherwise return Found => FALSE and Result is unpredictable. --| Skip means to skip white characters before scanning. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_LITERAL . SPEC -- . . -- .............................................. function Is_Literal (Chars : in STRING_TYPE; T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff T is at literal Chars. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_LITERAL . SPEC -- . . -- .............................................. function Is_Literal (Chars : in STRING; T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff T is at literal Chars. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_LITERAL . SPEC -- . . -- .............................................. procedure Scan_Literal (Chars : in STRING_TYPE; T : in SCANNER; Found : out BOOLEAN; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a literal Chars such that Char matches the sequence --| of characters in T. If found, return Found => TRUE, --| Otherwise return Found => FALSE --| Skip means to skip white characters before scanning. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_LITERAL . SPEC -- . . -- .............................................. procedure Scan_Literal (Chars : in STRING; T : in SCANNER; Found : out BOOLEAN; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a litral Chars such that Char matches the sequence --| of characters in T. If found, return Found => TRUE, --| Otherwise return Found => FALSE --| Skip means to skip white characters before scanning. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_NOT_LITERAL . SPEC -- . . -- .............................................. function Is_Not_Literal (Chars : in STRING; T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff T is not at literal Chars --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.IS_NOT_LITERAL . SPEC -- . . -- .............................................. function Is_Not_Literal (Chars : in STRING_TYPE; T : in SCANNER) return BOOLEAN; --| Purpose --| Return TRUE iff T is not at literal Chars --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_NOT_LITERAL . SPEC -- . . -- .............................................. procedure Scan_Not_Literal (Chars : in STRING; T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a literal Chars such that Char does not match the --| sequence of characters in T. If found, return Found => TRUE, --| Otherwise return Found => FALSE --| Skip means to skip white characters before scanning. --| --| Exceptions (none) --| Notes (none) -- .............................................. -- . . -- . STRING_SCANNER.SCAN_NOT_LITERAL . SPEC -- . . -- .............................................. procedure Scan_Not_Literal (Chars : in STRING_TYPE; T : in SCANNER; Found : out BOOLEAN; Result : out STRING_TYPE; Skip : in BOOLEAN := FALSE); --| Purpose --| Scan T for a litral Chars such that Char does not match the --| sequence of characters in T. If found, return Found => TRUE, --| Otherwise return Found => FALSE --| Skip means to skip white characters before scanning. --| --| Exceptions (none) --| Notes (none) private type SCAN_RECORD is record Text : STRING_TYPE; -- Copy of string being scanned Index : POSITIVE := 1; -- Current position of Scanner Mark : NATURAL := 0; -- Mark end record; type SCANNER is access SCAN_RECORD; end String_Scanner; --:::::::::: --tod.spc --:::::::::: -- **************************************************** -- * * -- * TOD_UTILITIES * SPEC -- * * -- **************************************************** with Calendar; -- Predefined (internal representation) TOD package. package TOD_Utilities is --| Purpose --| This package will provide direct conversion from an external --| time/date string to the internal Ada CALENDAR.TIME representation --| and vice versa. Most free format external representations are --| supported. Components of an external format include: --| Year, Month and Day (as numbers and strings), Hour, Minutes, --| and Seconds --| As long as the external representation can be parsed unambiguously, --| this package should be able to handle the conversion. Examples of --| legal external formats: --| 7pm Fr March 12, 1982 --| 15 Dec. 84 12:36PM --| YESTERDAY 3PM --| 6/01/83 <-- defaults to 12:00:00AM --| 3:45AM <-- defaults to the current date --| 18:07:35 <-- defaults to the current date --| 8-26 <-- defaults to 12:00:00AM of the current year --| friday <-- defaults to 12:00:00AM of the current or next --| future Friday --| Examples of illegal external representations: --| 2/31/84 <-- February never has a 31st day --| 12:3605/01/84 <-- too tough to parse (nondeterminstic) --| 3/8423:00:00 <-- too tough to parse (nondeterminstic) --| 3:54:29AMTues <-- too tough to parse (nondeterminstic) --| Nov 1983 <-- must always include day number in the date --| Sun 8/3/84 <-- 8/3/84 was a Friday --| --| Optional periods may be placed after ABBREVIATED day/month names. --| --| All external formats are converted to upper case, so there are no --| problems with specifying mixed and/or lower case input. All --| results are returned in upper case by default (which can be overridden --| by specifying lower case or mixed case). --| --| Special external formats: TODAY, TOMORROW, YESTERDAY, NOW --| TODAY is equivalent to 12AM of the current date. TOMORROW and --| YESTERDAY are equivalent to the next/previous date. NOW is --| equivalent to calling the function CALENDAR.CLOCK. --| --| Defaults: --| If the year is omitted, it defaults to the current year. If the --| time is omitted, it defaults to 12:00:00AM. If the day name and no --| date is specified, the current or next future date is assumed. If --| only the time is specified, the current date is assumed. If the --| minutes and/or seconds are not specified in the time, they default --| to zero. If the year is given in short format (1 or 2 digits) then --| it defaults to the current century. --| --| BNF for the external representation: --| {<special_format> [<time>] | --| [<time>] <special_format> | --| <day_string> &|* <date> &|* <time>} --| --| <special_format> ::= {TODAY | TOMORROW | YESTERDAY | NOW} --| --| <day_string> ::= SU|NDAY, MO|NDAY, ..., SA|TURDAY --| --| <date> ::= {<month_number><sep1><day_number>[<sep1><year_number>] | --| <month_name><sep2><day_number>[<sep2><year_number>] | --| <day_number><sep2><month_name>[<sep2><year_number>] | --| <full_year_number><sep2><month_name><sep2><day_number> | --| <full_year_number><sep2><day_number><sep2><month_name>} --| --| <time> ::= {<hour>':'<minutes>[':'<seconds>][<AM_PM>] | --| <AMPM_hour><AM_PM>} --| --| <month_number> ::= 1 .. 12 --| <month_name> ::= JAN|UARY, FEB|RUARY, ..., DEC|EMBER --| <day_number> ::= 1 .. 31 --| <year_number> ::= {<short_year_number> | <full_year_number>} --| <short_year_number> ::= [0]0 .. 99 <-- for century 2000 --| [0]1 .. 99 <-- for century 2100 --| <full_year_number> ::= 1901 .. 2099 --| <sep1> ::= {'-'|'/'} --| <sep2> ::= {<sep1> | {' ' | ','} ...} --| --| <hour> ::= [0]0 .. 24 --| <AMPM_hour> ::= [0]1 .. 12 --| <minutes> ::= 00 .. 59 --| <seconds> ::= 00 .. 59 --| <AM_PM> ::= {"AM" | "PM"} --| --| Notes on the BNF above: --| Items in angle brackets must be separated by at least one --| blank and/or comma when they appear with exactly one space --| between them. --| --| However, items in angle brackets which are not separated by --| exactly one blank have a more rigid syntax, and must be followed --| precisely as specified in the BNF. --| --| Some characters/strings are enclosed in quotes to emphasize that --| they are explicit, and not metasymbols. When specifying an --| external TOD_String, do NOT include the quotes. --| --| The AM/PM indicator may be left off the time if at least the --| hours and minutes are specified. If only the hour is specified, --| it must be in the range 01 .. 12 and must have the AM/PM --| indicator following it. If the AM/PM indicator is left off a --| time format, AM is assumed unless the hour is in the range --| 13 .. 23. If the AM/PM indicator is included, the hour must --| be in the range 01 .. 12. --| --| Notation: --| {...|...|...} -- Select exactly one alternative. --| [...] -- Optional. --| &| -- Select one or the other or both, --| &|* -- Same as &| with the extension of selecting --| the items in any order. --| ' ' -- Encloses a character literal. --| " " -- Encloses a string. --| < > -- Encloses a non-terminal symbol. --| ... -- Denotes a repeatable field. --| | -- Separates alternatives and denotes legal --| -- abbreviations. --| --| Initialization Exceptions (none) --| Notes (none) --| --| Modifications --| Author: Geoff Mendal, Stanford University External_TOD_Representation_Length : constant POSITIVE := 38; subtype EXTERNAL_TOD_REPRESENTATION_TYPE is STRING ( 1 .. External_TOD_Representation_Length); -- This type should be used to retrieve an external TOD -- representation from the CALENDAR.TIME representation. type TYPE_SET is (UPPER_CASE, lower_case, Mixed_Case); -- This type should be used to specify the type set of an -- external representation returned by the internal-to-external -- function below. -- .................................................. -- . . -- . TOD_UTILITIES.VERSION . SPEC -- . . -- .................................................. function Version return STRING; --| Purpose --| Returns the version number of this package. --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . TOD_UTILITIES.CONVERT . SPEC -- . . -- .................................................... function Convert ( TOD_Value : in CALENDAR.TIME; Default_Setting : in TYPE_SET := UPPER_CASE) return EXTERNAL_TOD_REPRESENTATION_TYPE; --| Purpose --| The following function will take the CALENDAR.TIME representation --| and return an external representation. The external representation --| has the following format: --| Columns 1 .. 9 : Day as a string --| Columns 11 .. 12 : Day as a number --| Columns 14 .. 22 : Month as a string --| Columns 24 .. 27 : year number --| Columns 29 .. 38 : time in AM/PM format --| All unused columns are blank --| --| Example string returned: --| "THURSDAY 09 AUGUST 1984 05:19:05PM" --| --| Exceptions (none) --| Notes (none) -- .................................................... -- . . -- . TOD_UTILITIES.NOW . SPEC -- . . -- .................................................... function Now (Default_Setting : in TYPE_SET := UPPER_CASE) return EXTERNAL_TOD_REPRESENTATION_TYPE; --| Purpose --| This function is a convenience, equivalent to calling --| the above Convert function with an argument of --| CALENDAR.CLOCK. The current time and date are --| returned as specified for Convert above. --| --| Exceptions (none) --| Notes --| Same as Convert(Calendar.Clock) -- .................................................... -- . . -- . TOD_UTILITIES.CONVERT . SPEC -- . . -- .................................................... function Convert (TOD_String : in STRING) return CALENDAR.TIME; --| Purpose --| This function will take an external TOD representation --| and return the CALENDAR.TIME representation. The external --| representation can be any STRING object that conforms to --| the BNF given above. --| --| Exceptions (see below) --| Notes (none) Duplication_Error, -- "5/25/61 May 25 1961" Date_Error, -- "2/31/75" Month_Number_Error, -- "13/1/1960" Year_Error, -- "1/1/1900" Day_Number_Error, -- "1/32/1984" Day_Date_Error, -- "Sunday 8/3/84" Month_Missing_Error, -- "1961 25" Day_Number_Missing_Error, -- "1961 May" Hour_Error, -- "25:00:00" Minute_Error, -- "23:61:00" Second_Error, -- "23:59:60" Time_String_Error, -- "1:05:05:PM" Abbreviation_Error, -- "Sept.emb. 5" External_Representation_Error : exception; -- "blah blah blah" -- These exceptions will be raised if the input to the -- above function cannot be parsed unambiguously. Also, this function -- traps CALENDAR.TIME_ERROR and instead raises the exception -- Date_Error below in its place. end TOD_Utilities;