Programmer's ROM - The Computer Language Library

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

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

Wrap

Text File | 1988-05-03 | 507.2 KB | 12,771 lines

-------- SIMTEL20 Ada Software Repository Prologue ------------ -- -* -- Unit name : Rainform Message Handler Package -- Version : 1.0 -- Contact : Lt. Colonel Falgiano -- : ESD/SCW -- : Hanscom AFB, MA 01731 -- Author : Tom Vollman -- : Veda, Inc. -- : 2 Three Notch Road -- : Lexington Park, MD 20653 -- DDN Address : CONTR 12 @NOSC-TECR (ARPANET) -- Copyright : (c) 1985 Veda, Inc. -- Date created : 22 October 1984 -- Release date : 15 April 1985 -- Last update : 3 May 1985 -- -* --------------------------------------------------------------- -- -* -- Keywords : ----------------: -- -- Abstract : This tool may be used to edit any formatted ----------------: message type that can be defined within the ----------------: specified boundries of the "generic message". ----------------: The tool is delivered with instances defined ----------------: for several Rainform message types and one ----------------: Non_Rainform message type. Additional types ----------------: may be instantiated with a re-compilation. ----------------: ----------------: This tool was developed as a precursor for ----------------: the WMCCS Information System (WIS). An ----------------: executable version of the tool has been ----------------: demonstrated. This source code has sub- ----------------: sequently been recompiled but has not under- ----------------: gone extensive testing. ----------------: -- -* ------------------ Revision history --------------------------- -- -* -- DATE VERSION AUTHOR HISTORY -- 05/03/85 1.0 Tom Vollman Initial Release -- -* ------------------ Distribution and Copyright ----------------- -- -* -- This prologue must be included in all copies of this software. -- -- This software is copyright by the author. -- -- This software is released to the Ada community. -- This software is released to the Public Domain (note: -- software released to the Public Domain is not subject -- to copyright protection). -- Restrictions on use or distribution: NONE -- -* ----------------- Disclaimer ---------------------------------- -- -* -- This software and its documentation are provided "AS IS" and -- without any expressed or implied warranties whatsoever. -- -- No warranties as to performance, merchantability, or fitness -- for a particular purpose exist. -- -- Because of the diversity of conditions and hardware under -- which this software may be used, no warranty of fitness for -- a particular purpose is offered. The user is advised to -- test the software thoroughly before relying on it. The user -- must assume the entire risk and liability of using this -- software. -- -- In no event shall any person or organization of people be -- held responsible for any direct, indirect, consequential -- or inconsequential damages or lost profits. -- -* ----------------- END-PROLOGUE ------------------------------- --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --termdef.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE TERMINAL_DEFINITION -- -- File name : TERMDEF.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- package TERMINAL_DEFINITION is use ASCII; -- -- this sub-package defines all terminal dependent data -- elements used by the gmhf system.if the systemis to -- be executed using a terminal other then the VT-100 -- series terminals, this package will have to be edited -- to handle the new characteristics.... -- -- -- start off with defining some general terminal characteristics -- NMBR_OF_ROWS : constant INTEGER := 24; NMBR_OF_COLS : constant INTEGER := 80; -- subtype CRT_ROWS is INTEGER range 1..NMBR_OF_ROWS; subtype CRT_COLS is INTEGER range 1..NMBR_OF_COLS; -- -- we define a record type to hold a crt position -- type CRT_POSITION is record ROW : CRT_ROWS; COLUMN : CRT_COLS; end record; -- -- since it is directly related to the crt dimensions, we will -- define the edit screen partitions: -- -- the title of the menu is on rows 1&2 TOP_OF_MESSAGE_AREA : constant CRT_ROWS := 3; TOP_OF_WORK_AREA : constant CRT_ROWS := 16; TOP_OF_AMP_AREA : constant CRT_ROWS := 20; -- -- from the tops of the areas, we may compute the bottoms -- BOT_OF_MESSAGE_AREA : constant CRT_ROWS := TOP_OF_WORK_AREA - 2; BOT_OF_WORK_AREA : constant CRT_ROWS := TOP_OF_AMP_AREA - 2; BOT_OF_AMP_AREA : constant CRT_ROWS := NMBR_OF_ROWS; -- -- if a message contains classified data and is displayed, -- the message's classification must be displayed in two -- places on the screen. the following declarations specifiy -- where the two locations should be. -- UPPER_CLASSIFICATION : CRT_POSITION := (ROW => 1, COLUMN => 1); LOWER_CLASSIFICATION : CRT_POSITION := (ROW => 24, COLUMN => 65); -- -- the system requires a set of function keys or a series of other -- keys to represent a function key. it is fairly standard practice -- for a function key to be symbolized by a special ascii character -- followed by one or several additional characters. the special -- ascii character should be common for all of the function keys. -- this system will operate based on the assumption that the user -- terminal supports this representation of a function key. below -- specifies the value of the leading special ascii character and -- the length of the string of characters to follow. -- -- for vt-100's the function key is represented by an escape followed -- by a string of two characters. -- START_OF_FUNCTION_KEY : CHARACTER := ESC; subtype FUNCTION_KEY is STRING (1..2); -- -- -- define the sequences which the terminal will echo back -- upon depression of the system driver function keys. -- if the number of available function keys are limited -- these keys may be defined as editing function keys also -- since both sets are never needed simultaniously. -- -- type SYSTEM_DRIVER_KEYS is record TAB : FUNCTION_KEY := "Op"; --sd1 BACK_TAB : FUNCTION_KEY := "On"; --sd2 COMMAND : FUNCTION_KEY := "OM"; --sd3 ARROW_UP : FUNCTION_KEY := "[A"; --sd4 ARROW_DOWN : FUNCTION_KEY := "[B"; --sd5 end record; -- -- -- now define the sequence which the terminal will echo -- upon depression of the special editing function keys. -- again these keys may double as system driver keys -- since both arent needed simultaneously -- type EDIT_FUNC_KEYS is record NEXT_FIELD : FUNCTION_KEY := "OR"; --ef1 PREV_FIELD : FUNCTION_KEY := "OS"; --ef2 ERASE_FIELD : FUNCTION_KEY := "OQ"; --ef3 NEXT_LINE : FUNCTION_KEY := "Oy"; --ef4 PREV_LINE : FUNCTION_KEY := "Om"; --ef5 INSERT_LINE : FUNCTION_KEY := "Ov"; --ef6 DELETE_LINE : FUNCTION_KEY := "Ol"; --ef7 EDIT_LINE : FUNCTION_KEY := "Ow"; --ef8 END_EDIT : FUNCTION_KEY := "OP"; --ef9 CLASSIFY : FUNCTION_KEY := "Ot"; --ef10 UP_ARROW : FUNCTION_KEY := "[A"; DOWN_ARROW : FUNCTION_KEY := "[B"; RIGHT_ARROW : FUNCTION_KEY := "[C"; LEFT_ARROW : FUNCTION_KEY := "[D"; NIL : FUNCTION_KEY := " "; end record; -- -- -- now specify all of the routines which are -- terminal dependent. these routines will have to be -- modified if a terminal which is not vt-100 compatable -- is used. -- procedure INT_STR (INPUT_VALUE : INTEGER; OUTPUT_STRING : out STRING; NUM_CHARS : in out INTEGER); procedure STR_INT (INPUT_STRING : in out STRING; OUTPUT_VALUE : out INTEGER); procedure GOTO_CRT_POSITION (ROW : in CRT_ROWS; COL : in CRT_COLS); procedure GOTO_CRT_POSITION (POSITION : CRT_POSITION); procedure UNDERSCORE_ON; procedure UNDERSCORE_OFF; procedure REVERSE_VIDEO_ON; procedure REVERSE_VIDEO_OFF; procedure ERASE_SCREEN; procedure ERASE_TO_END_OF_SCREEN; procedure ERASE_LINE; procedure SAVE_CURSOR_POSITION; procedure RESTORE_CURSOR_POSITION; procedure ERASE_LINE (LINE_NUMBER : in CRT_ROWS); procedure RING_BELL; procedure BACK_SPACE; procedure FORWARD_SPACE; -- procedure INITIALIZE_TERMINAL; -- end TERMINAL_DEFINITION; -- --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --termdef.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE TERMINAL_DEFINITION -- -- File name : TERMDEF.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; ----------------------------------- package body TERMINAL_DEFINITION is ----------------------------------- -- -- there are no data elements local only to this package -- because this package will not contain an executable driver. -- hence we will just define the procedures specified in the -- specificatioin portion of the package. -- -- ------------------ procedure INT_STR (INPUT_VALUE : INTEGER; OUTPUT_STRING : out STRING; NUM_CHARS : in out INTEGER) is ------------------ -- -- this procedure inputs an integer, and transforms it into a -- left-justified string. It returns the string and the number of -- non-blank characters in the string. -- type DEC_DIG is array (0..9) of STRING (1..1); DIG : DEC_DIG; -- this holds a copy of each digit in string form BLANKS : STRING (1..12) := " "; STR : STRING (1..12); -- this holds the string we are building SIGN : STRING (1..1); -- this holds the sign either a "-" or " " INT_VAL, CTR : INTEGER; -- int_val is the working value of the -- input value. ctr is a place holder. -- begin STR := " "; -- init working string DIG := (0 => "0", 1 => "1", 2 => "2", 3 => "3", 4 => "4", 5 => "5", 6 => "6", 7 => "7", 8 => "8", 9 => "9"); -- init digits INT_VAL := INPUT_VALUE; -- place input parameter into working spot -- if INT_VAL < 0 then -- set sign and ensure working value >0 SIGN := "-"; INT_VAL := - INT_VAL; else SIGN := " "; end if; -- for I in reverse 1..12 loop -- strip off the low order digits - STR (I) := DIG (INT_VAL mod 10) (1); -- place them into the work INT_VAL := (INT_VAL - (INT_VAL mod 10)) / 10; -- string. Then CTR := I; -- adjust the working value. Continue exit when INT_VAL = 0; -- until out of digits. end loop; -- if SIGN = "-" then -- set sign CTR := CTR - 1; STR (CTR) := SIGN (1); end if; -- NUM_CHARS := 12 - CTR + 1; -- calculate # of non-blank digits OUTPUT_STRING (1..NUM_CHARS) := STR (CTR..12); -- and place them -- into output string. end INT_STR; -- -- ------------------ procedure STR_INT (INPUT_STRING : in out STRING; OUTPUT_VALUE : out INTEGER) is ------------------ -- -- this procedure inputs a string, and transforms it into an -- integer. If it finds a non-digit it raises an exception : -- non_digit_input. -- -- It calls a subprogram, left_justify_and_validate, which in turn -- calls a subprogram, left_shift. -- type DEC_DIG is array (0..9) of STRING (1..1); DIG : DEC_DIG; -- this holds a copy of each digit in string form SIGN : INTEGER; NON_DIGIT_INPUT : exception; FIRST_DIGIT, LAST_DIGIT, TEMP_VALUE : INTEGER; FOUND_A_DIGIT : BOOLEAN; -- ----------------------------------- procedure LEFT_JUSTIFY_AND_VALIDATE (LAST_DIGIT : out INTEGER) is ----------------------------------- -- CURRENT_POSITION : POSITIVE; -- ----------------------- procedure LEFT_SHIFT is ----------------------- -- -- This proc shifts input_string to the left (over any leading -- blanks) and pads on the right with blanks. The position at -- which this routine begins its looking and shifting is found -- in current_position. -- I, J : POSITIVE; begin I := CURRENT_POSITION; J := I + 1; while (INPUT_STRING (I) = ' ' and CURRENT_POSITION <= INPUT_STRING'LENGTH) loop INPUT_STRING (I..INPUT_STRING'LENGTH) := INPUT_STRING (J..INPUT_STRING'LENGTH) & " "; CURRENT_POSITION := CURRENT_POSITION + 1; end loop; end LEFT_SHIFT; -- begin CURRENT_POSITION := 1; -- set pointer to beginning of string LEFT_SHIFT; -- get rid of any leading blanks -- if INPUT_STRING (1) = '-' then FIRST_DIGIT := 2; -- if the number is negative, set a else -- pointer to 2, else to 1. This ptr FIRST_DIGIT := 1; -- tells us where to start the shift/ end if; -- calculate loop. LAST_DIGIT := 0; VALIDATE_LOOP : for I in FIRST_DIGIT..INPUT_STRING'LENGTH loop -- CURRENT_POSITION := I; -- set ptr to 'next' character and LEFT_SHIFT; -- get rid of any leading blanks. if CURRENT_POSITION > INPUT_STRING'LENGTH then --if the rest exit VALIDATE_LOOP; --of the string was blank,we're done. end if; -- FOUND_A_DIGIT := FALSE; -- we're going to look to see if the INNER_LOOP : for J in 0..9 loop -- next char is a digit. If if INPUT_STRING (I..I) = DIG (J) then -- so then note the FOUND_A_DIGIT := TRUE; --fact and hold the position of LAST_DIGIT := I; -- this, the rightmost digit found, end if; -- so far. end loop INNER_LOOP; -- if FOUND_A_DIGIT = FALSE then --If we never raised the flag, raise NON_DIGIT_INPUT; -- then what was there was not a exit VALIDATE_LOOP; --digit, so take exception and go. end if; end loop VALIDATE_LOOP; -- -- end LEFT_JUSTIFY_AND_VALIDATE; -- -- begin TEMP_VALUE := 0; -- init output value DIG := (0 => "0", 1 => "1", 2 => "2", 3 => "3", 4 => "4", 5 => "5", 6 => "6", 7 => "7", 8 => "8", 9 => "9"); -- init digits -- LEFT_JUSTIFY_AND_VALIDATE (LAST_DIGIT); -- pack the string and make -- sure all characters are digits or blanks. if FIRST_DIGIT = 2 then SIGN := - 1; else -- If the first character was a '-', set SIGN := 1; -- sign = -1, else sign = 1. end if; -- for I in reverse FIRST_DIGIT..LAST_DIGIT loop -- digit at a time -- calculate the integer part INNER : for J in 0..9 loop if INPUT_STRING (I..I) = DIG (J) then TEMP_VALUE := TEMP_VALUE -- when one is found, calc + J * 10 ** (LAST_DIGIT - I); --its value exit INNER; end if; end loop INNER; end loop; TEMP_VALUE := TEMP_VALUE * SIGN; -- apply the algebraic sign. -- OUTPUT_VALUE := TEMP_VALUE; -- exception -- when non_digit_input => put_line("non-digit input in left"); -- end STR_INT; -- --------------------------- procedure GOTO_CRT_POSITION (ROW : in CRT_ROWS; COL : in CRT_COLS) is --------------------------- -- -- this procedure is tasked with performing absolute cursor -- addressing. It should, one way or another, move the active -- cursor position to the row and column specified in the -- argument list. -- -- this routine must first convert the numerical input to -- string variables so define the string variables. -- CHAR_ROW : STRING (1..2); CHAR_COL : STRING (1..2); N_DIGITS : INTEGER; M_DIGITS : INTEGER; -- -- begin -- -- -- the first thing we must do is convert the row and col to -- character strings. we do this by calling the utilty routine -- for this purpose. -- INT_STR (ROW, CHAR_ROW, N_DIGITS); INT_STR (COL, CHAR_COL, M_DIGITS); -- -- now write the escape sequence to the terminal to -- perform the absolute cursor positioning -- PUT (ESC); PUT ("[" & CHAR_ROW (1..N_DIGITS) & ";" & CHAR_COL (1..M_DIGITS) & "f"); -- -- end GOTO_CRT_POSITION; -- -- --------------------------- procedure GOTO_CRT_POSITION (POSITION : CRT_POSITION) is --------------------------- -- -- this procedure is tasked with performing absolute cursor -- addressing. It should, one way or another, move the active -- cursor position to the row and column specified in the -- argument list. -- -- this routine must first convert the numerical input to -- string variables so define the string variables. -- ROW : CRT_ROWS; COL : CRT_COLS; CHAR_ROW : STRING (1..2); CHAR_COL : STRING (1..2); N_DIGITS : INTEGER; M_DIGITS : INTEGER; -- -- begin -- -- this is an overloaded version of the goto_pos above, which -- requires a row and a column as inputs. this version accepts -- an element of crt_position, converts it to a row and a column -- and proceeds exactly as the version above. -- ROW := POSITION.ROW; COL := POSITION.COLUMN; -- -- the first thing we must do is convert the row and col to -- character strings. we do this by calling the utilty routine -- for this purpose. -- INT_STR (ROW, CHAR_ROW, N_DIGITS); INT_STR (COL, CHAR_COL, M_DIGITS); -- -- now write the escape sequence to the terminal to -- perform the absolute cursor positioning -- PUT (ESC); PUT ("[" & CHAR_ROW (1..N_DIGITS) & ";" & CHAR_COL (1..M_DIGITS) & "f"); -- -- end GOTO_CRT_POSITION; -- -- -------------------------- procedure UNDERSCORE_ON is -------------------------- -- -- this routine will turn the underscore characteristic for the -- user terminal on. for vt-100s its just an escape sequence. -- begin -- PUT (ESC); PUT ("[4m"); -- -- end UNDERSCORE_ON; -- -- --------------------------- procedure UNDERSCORE_OFF is --------------------------- -- -- this routine turns off the underscore characteristic for -- the user terminal. for vt-100s its just an escape sequence. -- CAUTION the same sequence also turns off reverse video -- begin -- PUT (ESC); PUT ("[0m"); -- -- end UNDERSCORE_OFF; -- -- ----------------------------- procedure REVERSE_VIDEO_ON is ----------------------------- -- -- this routine turns on the reverse video characteristic for -- the user terminal. for vt-100s its an escape sequence. -- begin -- PUT (ESC); PUT ("[7m"); -- -- end REVERSE_VIDEO_ON; -- -- ------------------------------ procedure REVERSE_VIDEO_OFF is ------------------------------ -- -- this routine turns the reverse video characteristic off -- for the user terminal. for vt-100s its an escape sequence. -- CAUTION- the same sequence also turns underscore off. -- begin -- PUT (ESC); PUT ("[0m"); -- -- end REVERSE_VIDEO_OFF; -- -- ------------------------- procedure ERASE_SCREEN is ------------------------- -- -- this routine erases the screen. for vt-100s its an escape -- sequence. -- begin -- PUT (ESC); PUT ("[2J"); -- -- end ERASE_SCREEN; -- -- ------------------------- procedure ERASE_TO_END_OF_SCREEN is ------------------------- -- -- this routine erases to the end of the screen. -- for vt-100s its an escape sequence. -- begin -- PUT (ESC); PUT ("[J"); -- -- end ERASE_TO_END_OF_SCREEN; -- -- ----------------------- procedure ERASE_LINE is ----------------------- -- -- this routine erase the current line the cursor is on. -- for vt-100s its an escape sequence. -- begin -- PUT (ESC); PUT ("[2K"); -- -- end ERASE_LINE; -- --------------------------------- procedure SAVE_CURSOR_POSITION is --------------------------------- -- -- this routine will save the current cursor position and -- all current attributes for the terminal which are set -- begin -- PUT (ESC); PUT ("7"); -- -- end SAVE_CURSOR_POSITION; -- -- ------------------------------------ procedure RESTORE_CURSOR_POSITION is ------------------------------------ -- -- this routine returns the cursor to where it was upon -- calling save_cursor_position and also resets the -- attributes to what they were -- begin -- PUT (ESC); PUT ("8"); -- -- end RESTORE_CURSOR_POSITION; -- -- ----------------------- procedure ERASE_LINE (LINE_NUMBER : in CRT_ROWS) is ----------------------- -- -- erases the line whose line number is passed as an -- argument and return the cursor back to where it was -- for the vt-100 it all can be done with escape sequences -- good luck doing it with any other terminal. -- begin -- SAVE_CURSOR_POSITION; -- -- now goto the row which needs to be erased -- GOTO_CRT_POSITION (LINE_NUMBER, 1); -- -- and erase line -- PUT (ESC); PUT ("[2K"); -- RESTORE_CURSOR_POSITION; -- -- end ERASE_LINE; -- -- ---------------------- procedure RING_BELL is ---------------------- -- -- this routine rings the terminal bell. -- bell is an ascii character. -- begin -- PUT (BEL); -- -- end RING_BELL; -- ---------------------- procedure BACK_SPACE is ---------------------- -- -- this routine backspaces the cursor one position -- bs is an ascii character. -- begin -- PUT (BS); -- -- end BACK_SPACE; -- ---------------------- procedure FORWARD_SPACE is ---------------------- -- -- this routine moves the cursor forward one position -- fs is an ascii character. -- begin -- PUT (FS); -- -- end FORWARD_SPACE; -- ---------------------- procedure INITIALIZE_TERMINAL is ---------------------- -- -- this routine allows the implementor to do any terminal -- initialization. For VT 100s, we set the application keypad. -- begin -- PUT (ESC); PUT ("="); -- -- end INITIALIZE_TERMINAL; -- -- end TERMINAL_DEFINITION; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmip.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE MAN_MACHINE_INTERFACE -- -- File name : MMIP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -------------------------------- package MAN_MACHINE_INTERFACE is -------------------------------- -- -- mmip is a package used to define all data element and -- processing element definitions which will be used for -- communications between the user and the gmhf system.. -- -- the following contains miscellaneous -- data element and processing element definitions for -- man/machine interface use. these routines should be terminal -- independent but they may be host dependent. -- -- -- a few data definitions for use as arguments -- type UP_OR_DOWN is (UP, DOWN); type COMMAND is (NEXT_FIELD, PREV_FIELD, ERASE_FIELD, NEXT_LINE, PREV_LINE, INSERT_LINE, DELETE_LINE, EDIT_LINE, END_EDIT, CLASSIFY, UP_ARROW, DOWN_ARROW, RIGHT_ARROW, LEFT_ARROW, NIL); -- -- procedure PROMPT (TEXT : in STRING); procedure DISPLAY_MENU (MENU_NAME : STRING); procedure SCROLL_SCREEN (TOP_OF_SCROLL_AREA, BOTTOM_OF_SCROLL_AREA : POSITIVE; DIRECTION : in UP_OR_DOWN); procedure GET_COMMAND (EDIT_COMMAND : out COMMAND); procedure READ_NOECHO (TEXT : in out STRING); procedure READ (TEXT : in out STRING; NUM_CHAR : in POSITIVE; COMMAND_FLAG : out BOOLEAN; EDIT_COMMAND : out COMMAND); -- end MAN_MACHINE_INTERFACE; -- --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --mmip.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE MAN_MACHINE_INTERFACE -- -- File name : MMIP.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with HOST_LCD_IF; use HOST_LCD_IF; with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; ------------------------------------------------- package body MAN_MACHINE_INTERFACE is ------------------------------------------------- package INT_IO is new INTEGER_IO (INTEGER); use INT_IO; PROMPT_DISPLAYED : BOOLEAN; -- -- -- there are no data elements local only to this package -- because this package will not contain an executable driver. -- hence we will just define the procedures specified in the -- specification portion of the package. -- -- ----------------- procedure PROMPT (TEXT : in STRING) is ----------------- -- -- this routine will prompt the user with the string passed as -- an argument. the prompt will appear on the second row of the -- menus. -- PROMPT_STRING : STRING (1..NMBR_OF_COLS) := (1..NMBR_OF_COLS => ' '); begin -- -- the first thing we must do is save the cursor position -- SAVE_CURSOR_POSITION; -- -- then move to the prompt area, ring the bell, -- and then put out the string -- GOTO_CRT_POSITION (2, 1); if PROMPT_DISPLAYED = FALSE then RING_BELL; end if; -- -- then turn on underscore -- REVERSE_VIDEO_OFF; -- make sure everythings off first UNDERSCORE_ON; -- -- then put out the string -- PROMPT_STRING (1..TEXT'LENGTH) := TEXT; PUT (PROMPT_STRING); -- -- now restore cursor position -- RESTORE_CURSOR_POSITION; -- PROMPT_DISPLAYED := TRUE; -- end PROMPT; -- -- ----------------------- procedure DISPLAY_MENU (MENU_NAME : STRING) is ----------------------- -- -- this routine reads a sequential file for each menu and -- echoes the contents back to the terminal. -- NUMBER_OF_CHARACTERS : NATURAL; SCREEN_STRING : STRING (1..256); FILE_1 : TEXT_IO.FILE_TYPE; begin -- -- -- -- open the file specified by menu_name -- OPEN (FILE_1, IN_FILE, MENU_NAME & ".dsp", ""); ERASE_SCREEN; while not END_OF_FILE (FILE_1) loop -- read one line at a time and load the values into -- the screen_string array unti end of file is reached -- GET_LINE (FILE_1, SCREEN_STRING, NUMBER_OF_CHARACTERS); -- -- with a put(string) put all of the characters out -- to the terminal. this will display the screen. -- number_of_characters is decremented by 1 because -- the loop is top tested therefore it gets incremented 1 -- too many times. -- PUT (SCREEN_STRING (1..NUMBER_OF_CHARACTERS)); -- end loop; CLOSE (FILE_1); -- end DISPLAY_MENU; -- -- ------------------------- procedure SCROLL_SCREEN (TOP_OF_SCROLL_AREA, BOTTOM_OF_SCROLL_AREA : POSITIVE; DIRECTION : in UP_OR_DOWN) is ------------------------- -- -- this routine scrolls the displayed message up or down on -- the user terminal as specified. -- DIRECTION_STRING : STRING (1..1); TOP_STRING : STRING (1..2); BOTTOM_STRING : STRING (1..2); ROW_NUMBER : POSITIVE; begin PUT (TOP_STRING, TOP_OF_SCROLL_AREA); if TOP_STRING (1) = ' ' then TOP_STRING (1) := '0'; end if; PUT (BOTTOM_STRING, BOTTOM_OF_SCROLL_AREA); if BOTTOM_STRING (1) = ' ' then BOTTOM_STRING (1) := '0'; end if; PUT (ASCII.ESC); PUT ("[" & TOP_STRING & ";" & BOTTOM_STRING & "r"); if DIRECTION = UP then ROW_NUMBER := BOTTOM_OF_SCROLL_AREA; DIRECTION_STRING := "D"; else ROW_NUMBER := TOP_OF_SCROLL_AREA; DIRECTION_STRING := "M"; end if; GOTO_CRT_POSITION (ROW_NUMBER, 1); PUT (ASCII.ESC); PUT (DIRECTION_STRING); PUT (BOTTOM_STRING, NMBR_OF_ROWS); PUT (ASCII.ESC); PUT ("[1;" & BOTTOM_STRING & "r"); -- end SCROLL_SCREEN; -- -- ---------------------------- procedure READ_NOECHO (TEXT : in out STRING) is ---------------------------- -- this routine is written in iwth direct use of the KAPSE. -- the routines used within are further described in the installation -- guide for TeleSoft under the LCD section. -- this routine will read a string of characters with no echo. -- it is primarily designed to read only one character since -- backspace and del aren't acknowledged. -- -- -- info is a record which defines how to open the terminal -- INFO : FILE_INFO; F : FILENO; LAST : STRING_INDEX; WHY_LESS : TERMINATOR; RESULT : ERROR_CLASS; -- begin INFO.FILE_TYPE := TEXT_KIND; INFO.TERMINAL := TRUE; INFO.CHARACTER_MODE := TRUE; INFO.NEEDS_ECHO := TRUE; INFO.EOLN_CH := ASCII.NUL; INFO.EOP_CH := ASCII.NUL; INFO.EOF_CH := ASCII.NUL; INFO.BACKSPACE_CH := ASCII.NUL; INFO.DEL_CH := ASCII.NUL; -- -- open the terminal as an input device -- FS_OPEN (F, "sys$input:", "", CONSOLE, SEQUENTIAL_ACCESS, TEXT_KIND, "", IN_OUT_MODE, FALSE, TRUE, 132, RESULT); -- -- now the terminal is open so set some characteristics -- with a put_info -- FS_PUT_INFO (F, INFO, RESULT); -- -- get the characters -- FS_GET_CHARS (F, TEXT, LAST, WHY_LESS, RESULT); -- -- close the terminal as a file -- FS_CLOSE (F, RESULT); -- -- end READ_NOECHO; -- --------------------- procedure GET_COMMAND (EDIT_COMMAND : out COMMAND) is --------------------- -- -- this routine will return a edit function command issued by the usr -- KEY_FOR : EDIT_FUNC_KEYS; KEY : FUNCTION_KEY; -- from termdef CHAR : CHARACTER; BLANK_LINE : STRING (1..NMBR_OF_COLS) := (1..NMBR_OF_COLS => ' '); begin READ_NOECHO (KEY); ------ -- -- now convert the string into an element of the enumerated -- type command. This is done to make the editor pure of -- references to function keys. -- if KEY = KEY_FOR.NEXT_FIELD then EDIT_COMMAND := NEXT_FIELD; elsif KEY = KEY_FOR.PREV_FIELD then EDIT_COMMAND := PREV_FIELD; elsif KEY = KEY_FOR.ERASE_FIELD then EDIT_COMMAND := ERASE_FIELD; elsif KEY = KEY_FOR.NEXT_LINE then EDIT_COMMAND := NEXT_LINE; elsif KEY = KEY_FOR.PREV_LINE then EDIT_COMMAND := PREV_LINE; elsif KEY = KEY_FOR.INSERT_LINE then EDIT_COMMAND := INSERT_LINE; elsif KEY = KEY_FOR.DELETE_LINE then EDIT_COMMAND := DELETE_LINE; elsif KEY = KEY_FOR.EDIT_LINE then EDIT_COMMAND := EDIT_LINE; elsif KEY = KEY_FOR.END_EDIT then EDIT_COMMAND := END_EDIT; elsif KEY = KEY_FOR.CLASSIFY then EDIT_COMMAND := CLASSIFY; elsif KEY = KEY_FOR.UP_ARROW then EDIT_COMMAND := UP_ARROW; elsif KEY = KEY_FOR.DOWN_ARROW then EDIT_COMMAND := DOWN_ARROW; elsif KEY = KEY_FOR.RIGHT_ARROW then EDIT_COMMAND := RIGHT_ARROW; elsif KEY = KEY_FOR.LEFT_ARROW then EDIT_COMMAND := LEFT_ARROW; else EDIT_COMMAND := NIL; end if; if PROMPT_DISPLAYED = TRUE then PROMPT (BLANK_LINE); PROMPT_DISPLAYED := FALSE; end if; end GET_COMMAND; -- -- -------------------- procedure READ (TEXT : in out STRING; NUM_CHAR : in POSITIVE; COMMAND_FLAG : out BOOLEAN; EDIT_COMMAND : out COMMAND) is -------------------- -- FAKE_CHARACTER : STRING (1..1); COUNT : INTEGER; begin -- -- COMMAND_FLAG := FALSE; COUNT := 1; while COUNT <= NUM_CHAR loop READ_NOECHO (FAKE_CHARACTER); exit when FAKE_CHARACTER (1) = ASCII.CR or FAKE_CHARACTER (1) = ASCII.ESC; if (FAKE_CHARACTER (1) = ASCII.BS or FAKE_CHARACTER (1) = ASCII.DEL) and (COUNT /= 1) then PUT (FAKE_CHARACTER); COUNT := COUNT - 1; if FAKE_CHARACTER (1) = ASCII.DEL then TEXT (COUNT) := ' '; end if; else if FAKE_CHARACTER (1) /= ASCII.BS and FAKE_CHARACTER (1) /= ASCII.DEL then TEXT (COUNT) := FAKE_CHARACTER (1); PUT (FAKE_CHARACTER); COUNT := COUNT + 1; end if; end if; end loop; if FAKE_CHARACTER (1) = ASCII.ESC then GET_COMMAND (EDIT_COMMAND); COMMAND_FLAG := TRUE; end if; -- end READ; -- end MAN_MACHINE_INTERFACE; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --typelist.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE TYPE_LIST -- -- File name : TYPELIST.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- package TYPE_LIST is -- -- specification for all message types -- currently supported by the system -- type AVAILABLE_TYPES is (RAINFORM, UNITREP); -- end TYPE_LIST; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --class.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE CLASSIFICATION_DEFINITION -- -- File name : CLASS.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- ------------------------------------------------------- package CLASSIFICATION_DEFINITION is ------------------------------------------------------- -- -- classification is a package used to define a type for classification -- and routines to get a user entered classification and to display a -- classification to the screen -- type CLASSIFICATION is (UNCLASSIFIED, CONFIDENTIAL, SECRET, TOP_SECRET ); procedure GET_CLASSIFICATION (CLASS : out CLASSIFICATION); procedure DISPLAY_CLASSIFICATION (CLASS : in CLASSIFICATION); -- procedure DISPLAY_LOWER_CLASSIFICATION (CLASS : in CLASSIFICATION); -- end CLASSIFICATION_DEFINITION; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --class.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE CLASSIFICATION_DEFINITION -- -- File name : CLASS.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with TEXT_IO; use TEXT_IO; ------------------------------------------------- package body CLASSIFICATION_DEFINITION is ------------------------------------------------- -- INDEX : POSITIVE; subtype CLASS_STRING is STRING (1..12); type CLASS_ARRAY is array (CLASSIFICATION) of CLASS_STRING; CLASS_PROMPT : CLASS_ARRAY := (UNCLASSIFIED => "UNCLASSIFIED", CONFIDENTIAL => "CONFIDENTIAL", SECRET => "SECRET ", TOP_SECRET => "TOP SECRET "); BLANKS : CLASS_STRING := " "; type CLASS_PROMPT_LENGTH is array (CLASSIFICATION) of POSITIVE; CLASS_LENGTH : CLASS_PROMPT_LENGTH := (UNCLASSIFIED => 12, CONFIDENTIAL => 12, SECRET => 6, TOP_SECRET => 10); package CLASS_IO is new ENUMERATION_IO (CLASSIFICATION); ---------------------------- procedure GET_CLASSIFICATION (CLASS : out CLASSIFICATION) is ---------------------------- DUMMY_STRING : STRING (1..12); CHARACTERS_GOTTEN : POSITIVE; COMMAND_FLAG : BOOLEAN; COMMAND_GOTTEN : COMMAND; begin loop begin READ (DUMMY_STRING, 12, COMMAND_FLAG, COMMAND_GOTTEN); if DUMMY_STRING (1..4) = "TOP " then DUMMY_STRING (1..4) := "TOP_"; end if; CLASS_IO.GET (DUMMY_STRING, CLASS, CHARACTERS_GOTTEN); exit; exception when END_ERROR => exit; when others => PROMPT ("Invalid classification entry. Please reenter data."); GOTO_CRT_POSITION (TOP_OF_AMP_AREA + 3, 40); end; end loop; end GET_CLASSIFICATION; -- -------------------------------- procedure DISPLAY_CLASSIFICATION (CLASS : in CLASSIFICATION) is -------------------------------- begin GOTO_CRT_POSITION (UPPER_CLASSIFICATION); UNDERSCORE_ON; PUT (BLANKS); GOTO_CRT_POSITION (UPPER_CLASSIFICATION); PUT (CLASS_PROMPT (CLASS) (1..CLASS_LENGTH (CLASS))); GOTO_CRT_POSITION (LOWER_CLASSIFICATION); UNDERSCORE_OFF; PUT (BLANKS); UNDERSCORE_ON; GOTO_CRT_POSITION (LOWER_CLASSIFICATION); PUT (CLASS_PROMPT (CLASS) (1..CLASS_LENGTH (CLASS))); UNDERSCORE_OFF; end DISPLAY_CLASSIFICATION; -------------------------------- procedure DISPLAY_LOWER_CLASSIFICATION (CLASS : in CLASSIFICATION) is -------------------------------- begin GOTO_CRT_POSITION (LOWER_CLASSIFICATION); PUT (BLANKS); UNDERSCORE_ON; GOTO_CRT_POSITION (LOWER_CLASSIFICATION); PUT (CLASS_PROMPT (CLASS) (1..CLASS_LENGTH (CLASS))); UNDERSCORE_OFF; end DISPLAY_LOWER_CLASSIFICATION; end CLASSIFICATION_DEFINITION; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --lnklst.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE LINKED_LIST_PROCEDURED -- -- File name : LNKLST.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with CLASSIFICATION_DEFINITION; use CLASSIFICATION_DEFINITION; --------------------------------------- package LINKED_LIST_PROCEDURES is --------------------------------------- -- this package contains three procedures needed to edit a -- message as a linked list of lines. The three visible -- procedures allow one to insert a line before or after -- the node specified, and to delete the node specified. -- The structure implemented is a doubly linked list with -- pointers to the head and tail. See the definitions of -- message_component and message. -- -- node is defined as access to elements of type message_component -- subtype LINE_OF_TEXT is STRING (1..80); -- type MESSAGE_COMPONENT; -- type NODE is access MESSAGE_COMPONENT; -- type MESSAGE_COMPONENT is record NEXT_LINE : NODE; PREV_LINE : NODE; LINE_TYPE : POSITIVE; TEXT_LINE : LINE_OF_TEXT := (OTHERS => ' '); end record; -- -- a message is then defined as an entity of type message. in -- defining a message, we specify pointers to its head and tail -- (first and last lines), its classification, and keep current -- the number of lines in the message. -- type MESSAGE is record HEAD : NODE; TAIL : NODE; CLASS : CLASSIFICATION; NUMBER_OF_LINES : POSITIVE; end record; -- procedure INSERT_BEFORE (INPUT_MESSAGE : in out MESSAGE; POINTER : NODE); procedure INSERT_AFTER (INPUT_MESSAGE : in out MESSAGE; POINTER : NODE); procedure DELETE (INPUT_MESSAGE : in out MESSAGE; POINTER : NODE); -- end LINKED_LIST_PROCEDURES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --lnklst.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE LINKED_LIST_PROCEDURES -- -- File name : LNKLST.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; --------------------------------------- package body LINKED_LIST_PROCEDURES is --------------------------------------- -- this package contains three procedures needed to edit a -- message as a linked list of lines. The three visible -- procedures allow one to insert a line before or after -- the node specified, and to delete the node specified. -- The structure implemented is a doubly linked list with -- pointers to the head and tail. See the definitions of -- message_component and message. -- ------------------------------------ procedure INSERT_BEFORE (INPUT_MESSAGE : in out MESSAGE; POINTER : NODE) is ------------------------------------ NEW_POINTER : NODE; -- holds pointer to a new message component begin -- -- first check boundary condition -- if POINTER = null then PROMPT ("cannot insert a line in a non-existant message"); return; end if; -- -- its ok to add the line, so go get a new message_component -- and set the pointers. If the new line will be the head, -- set them in the then block, otherwise in the else block -- NEW_POINTER := new MESSAGE_COMPONENT; -- if POINTER = INPUT_MESSAGE.HEAD then --new first line ? NEW_POINTER.NEXT_LINE := POINTER; -- link new line to POINTER.PREV_LINE := NEW_POINTER; -- following line INPUT_MESSAGE.HEAD := NEW_POINTER; --set head pointer -- below, link new line to precedng line NEW_POINTER.PREV_LINE := INPUT_MESSAGE.TAIL; INPUT_MESSAGE.TAIL.NEXT_LINE := NEW_POINTER; -- else -- not new first line NEW_POINTER.NEXT_LINE := POINTER; -- set pointers in NEW_POINTER.PREV_LINE := POINTER.PREV_LINE; -- new line POINTER.PREV_LINE.NEXT_LINE := NEW_POINTER; -- set them in POINTER.PREV_LINE := NEW_POINTER; -- preceding and -- following lines end if; -- end INSERT_BEFORE; -- ----------------------------------- procedure INSERT_AFTER (INPUT_MESSAGE : in out MESSAGE; POINTER : NODE) is ----------------------------------- NEW_POINTER : NODE; --holds a pointer to a new message component begin -- -- first check boundary condition -- if POINTER = null then PROMPT ("cannot insert a line in a non-existant message"); return; end if; -- -- its ok to add the line, so go get a new message_component -- and set the pointers. If the new line will be the tail, -- set them in the then block, otherwise in the else block -- NEW_POINTER := new MESSAGE_COMPONENT; -- if POINTER = INPUT_MESSAGE.TAIL then -- new last line ? NEW_POINTER.PREV_LINE := POINTER; -- link new line to POINTER.NEXT_LINE := NEW_POINTER; -- preceding line INPUT_MESSAGE.TAIL := NEW_POINTER; --set tail pointer --below, link new line to following line NEW_POINTER.NEXT_LINE := INPUT_MESSAGE.HEAD; INPUT_MESSAGE.HEAD.PREV_LINE := NEW_POINTER; -- else -- not new last line NEW_POINTER.PREV_LINE := POINTER; -- set pointers in NEW_POINTER.NEXT_LINE := POINTER.NEXT_LINE; -- new line POINTER.NEXT_LINE.PREV_LINE := NEW_POINTER; -- set them POINTER.NEXT_LINE := NEW_POINTER; -- in previous and -- following lines end if; -- end INSERT_AFTER; -- ------------------------------ procedure DELETE (INPUT_MESSAGE : in out MESSAGE; POINTER : NODE) is ------------------------------ begin -- -- first check boundary condition -- if POINTER = null then PROMPT ("cannot delete a line from an empty message"); return; end if; -- -- its ok to delete the line, so determine whether it is a -- one line message or whether it is longer. If it is a one -- line message, handle it in the then block, otherwise in -- the else block -- if INPUT_MESSAGE.HEAD = INPUT_MESSAGE.TAIL then INPUT_MESSAGE.HEAD := null; -- set head and tail INPUT_MESSAGE.TAIL := null; -- pointers to null INPUT_MESSAGE.NUMBER_OF_LINES := 0; -- and # lines= 0 -- else -- more than one line -- -- set preceding line pointer and following line pointer -- POINTER.PREV_LINE.NEXT_LINE := POINTER.NEXT_LINE; POINTER.NEXT_LINE.PREV_LINE := POINTER.PREV_LINE; -- -- if the line being deleted is the head and/or the tail -- we must reset the head/tail pointer(s) -- if POINTER = INPUT_MESSAGE.HEAD then -- reset head INPUT_MESSAGE.HEAD := POINTER.NEXT_LINE; --pointer end if; -- if POINTER = INPUT_MESSAGE.TAIL then -- reset tail INPUT_MESSAGE.TAIL := POINTER.PREV_LINE; --pointer end if; -- -- *** need to insert a call to an instance of a de-allocate proc here -- end if; end DELETE; -- end LINKED_LIST_PROCEDURES; -- --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --fap.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE FILE_ACCESS -- -- File name : FAP.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with LINKED_LIST_PROCEDURES; use LINKED_LIST_PROCEDURES; with TYPE_LIST; use TYPE_LIST; -- package FILE_ACCESS is -- -- This package is available only to routines internal to -- the system driver package. The routines deal mainly with -- managing the messages of the internal database. -- External users may not utilize any of these routines. -- -- linked_list directory structure -- type DIRECTORY_STRUCTURE; -- incomplete type declaration type DIRECTORY_ENTRY is access DIRECTORY_STRUCTURE; type DIRECTORY_STRUCTURE is record MESSAGE_TYPE : AVAILABLE_TYPES; MESSAGE_FILENAME : STRING (1..9); NUMBER_OF_MESSAGES : NATURAL; PREVIOUS_MESSAGE_TYPE : DIRECTORY_ENTRY; NEXT_MESSAGE_TYPE : DIRECTORY_ENTRY; TYPE_STRING : STRING (1..11); NUMBER_STRING : STRING (1..5); end record; TOP_OF_DIRECTORY : DIRECTORY_ENTRY; -- -- returns a pointer to the top of the directory -- procedure GET_DIRECTORY (TOP_OF_DIRECTORY : out DIRECTORY_ENTRY); -- -- retrieves a message from the internal data base -- procedure GET_MESSAGE_OUT (DIRECTORY_POINTER : in DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL; MESSAGE_TEXT : in out MESSAGE); -- -- adds a new message to the internal data base -- procedure PUT_NEW_MESSAGE_IN (DIRECTORY_POINTER : in DIRECTORY_ENTRY; MESSAGE_TEXT : in MESSAGE); -- -- replaces a message within the internal data base -- procedure PUT_OLD_MESSAGE_BACK_IN (DIRECTORY_POINTER : in DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL; MESSAGE_TEXT : in MESSAGE); -- -- deletes a message from the internal data base -- procedure DELETE_MESSAGE_FROM_DATABASE (DIRECTORY_POINTER : in out DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL); end FILE_ACCESS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --fap.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE FILE_ACCESS -- -- File name : FAP.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with CLASSIFICATION_DEFINITION; use CLASSIFICATION_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with DIRECT_IO; with CALENDAR; with TEXT_IO; use TEXT_IO; package body FILE_ACCESS is -- -- This package is available only to routines internal to -- the system driver package. The routines deal mainly with -- managing the messages of the internal database. -- External users may not utilize any of these routines. -- ----------------------------------------------- -- -- local variables and direct_io instantiations -- ----------------------------------------------- -- RECORD_ERROR : exception; -- -- define the internal storage format of a message -- type MESSAGE_FORMAT is array (1..25) of STRING (1..80); -- type MESSAGE_RECORD is record CLASS : CLASSIFICATION; NUMBER_OF_LINES : POSITIVE; MONTH, DAY, YEAR : INTEGER; CONTENT : MESSAGE_FORMAT; end record; -- package DIRECTORY_IO is new DIRECT_IO (DIRECTORY_STRUCTURE); use DIRECTORY_IO; FILE_1 : DIRECTORY_IO.FILE_TYPE; RECORD_NUMBER : DIRECTORY_IO.POSITIVE_COUNT; -- DIRECTORY_RECORD : DIRECTORY_STRUCTURE; -- package MESSAGE_IO is new DIRECT_IO (MESSAGE_RECORD); use MESSAGE_IO; FILE_2 : MESSAGE_IO.FILE_TYPE; MESSAGE_RECORD_NUMBER : MESSAGE_IO.POSITIVE_COUNT; -- MESSAGE_DATA : MESSAGE_RECORD; -- LINE_NUMBER : POSITIVE; FOUND : BOOLEAN; -- MONTH, DAY, YEAR : INTEGER; -- package MESSAGE_TYPE_IO is new ENUMERATION_IO (AVAILABLE_TYPES); package NATURAL_IO is new INTEGER_IO (NATURAL); -- ---------------------------------------- -- local date routine ---------------------------------------- procedure GET_THE_DATE (MONTH, DAY, YEAR : out INTEGER) is -- COMPUTE_TIME : CALENDAR.TIME; -- begin -- COMPUTE_TIME := CALENDAR.CLOCK; -- MONTH := CALENDAR.MONTH (COMPUTE_TIME); DAY := CALENDAR.DAY (COMPUTE_TIME); YEAR := CALENDAR.YEAR (COMPUTE_TIME); -- end GET_THE_DATE; -- -- ---------------------------------------- procedure GET_DIRECTORY (TOP_OF_DIRECTORY : out DIRECTORY_ENTRY) is ---------------------------------------- CURRENT_POINTER : DIRECTORY_ENTRY; NEXT_POINTER : DIRECTORY_ENTRY; -- -- begin -- -- open the directory -- OPEN (FILE_1, INOUT_FILE, "MSGDRCTRY.DAT", ""); -- -- save the top of the directory linked list -- CURRENT_POINTER := new DIRECTORY_STRUCTURE; TOP_OF_DIRECTORY := CURRENT_POINTER; -- -- load the first directory entry -- RECORD_NUMBER := 1; READ (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); -- -- store the contents at current_pointer -- CURRENT_POINTER.MESSAGE_TYPE := DIRECTORY_RECORD.MESSAGE_TYPE; CURRENT_POINTER.MESSAGE_FILENAME := DIRECTORY_RECORD.MESSAGE_FILENAME; CURRENT_POINTER.NUMBER_OF_MESSAGES := DIRECTORY_RECORD.NUMBER_OF_MESSAGES; CURRENT_POINTER.PREVIOUS_MESSAGE_TYPE := null; CURRENT_POINTER.TYPE_STRING := DIRECTORY_RECORD.TYPE_STRING; CURRENT_POINTER.NUMBER_STRING := DIRECTORY_RECORD.NUMBER_STRING; -- -- now get the rest of the records -- while not END_OF_FILE (FILE_1) loop -- NEXT_POINTER := new DIRECTORY_STRUCTURE; RECORD_NUMBER := RECORD_NUMBER + 1; READ (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); -- NEXT_POINTER.MESSAGE_TYPE := DIRECTORY_RECORD.MESSAGE_TYPE; NEXT_POINTER.MESSAGE_FILENAME := DIRECTORY_RECORD.MESSAGE_FILENAME; NEXT_POINTER.NUMBER_OF_MESSAGES := DIRECTORY_RECORD.NUMBER_OF_MESSAGES; NEXT_POINTER.PREVIOUS_MESSAGE_TYPE := CURRENT_POINTER; NEXT_POINTER.TYPE_STRING := DIRECTORY_RECORD.TYPE_STRING; NEXT_POINTER.NUMBER_STRING := DIRECTORY_RECORD.NUMBER_STRING; -- CURRENT_POINTER.NEXT_MESSAGE_TYPE := NEXT_POINTER; CURRENT_POINTER := NEXT_POINTER; -- end loop; -- CLOSE (FILE_1); -- end GET_DIRECTORY; -- -------------------------------------- procedure GET_MESSAGE_OUT (DIRECTORY_POINTER : in DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL; MESSAGE_TEXT : in out MESSAGE) is -------------------------------------- -- MESSAGE_POINTER : NODE; -- -- begin -- PROMPT("Retrieving data base message"); -- -- open the message file and read the first record -- OPEN (FILE_2, INOUT_FILE, DIRECTORY_POINTER.MESSAGE_FILENAME & ".MSG", ""); -- if MESSAGE_NUMBER > DIRECTORY_POINTER.NUMBER_OF_MESSAGES OR MESSAGE_NUMBER = 0 then MESSAGE_RECORD_NUMBER := 1; else MESSAGE_RECORD_NUMBER := MESSAGE_IO.POSITIVE_COUNT ((MESSAGE_NUMBER * 4 + 1)); end if; -- READ (FILE_2, MESSAGE_DATA, MESSAGE_RECORD_NUMBER); -- -- load the first record into memory -- MESSAGE_POINTER := new MESSAGE_COMPONENT; -- MESSAGE_TEXT.HEAD := MESSAGE_POINTER; MESSAGE_TEXT.TAIL := MESSAGE_POINTER; MESSAGE_TEXT.CLASS := MESSAGE_DATA.CLASS; MESSAGE_TEXT.NUMBER_OF_LINES := MESSAGE_DATA.NUMBER_OF_LINES; -- MESSAGE_POINTER.NEXT_LINE := null; MESSAGE_POINTER.PREV_LINE := null; MESSAGE_POINTER.TEXT_LINE := MESSAGE_DATA.CONTENT (1); -- -- load the remaining lines into memory; an additional record must -- be read after 25, 50 and 75 lines -- LINE_NUMBER := 1; for I in 2..MESSAGE_DATA.NUMBER_OF_LINES loop LINE_NUMBER := LINE_NUMBER + 1; if LINE_NUMBER > 25 then MESSAGE_RECORD_NUMBER := MESSAGE_RECORD_NUMBER + 1; if NATURAL (MESSAGE_RECORD_NUMBER) >= (MESSAGE_NUMBER + 1) * 4 + 1 then raise RECORD_ERROR; end if; LINE_NUMBER := 1; READ (FILE_2, MESSAGE_DATA, MESSAGE_RECORD_NUMBER); end if; INSERT_AFTER (MESSAGE_TEXT, MESSAGE_POINTER); MESSAGE_POINTER := MESSAGE_POINTER.NEXT_LINE; MESSAGE_POINTER.TEXT_LINE := MESSAGE_DATA.CONTENT (LINE_NUMBER); end loop; -- -- CLOSE (FILE_2); -- exception -- when RECORD_ERROR => CLOSE (FILE_2); PROMPT ("Too many lines this message, only 100 lines saved"); -- end GET_MESSAGE_OUT; -- ----------------------------------------- procedure PUT_NEW_MESSAGE_IN (DIRECTORY_POINTER : in DIRECTORY_ENTRY; MESSAGE_TEXT : in MESSAGE) is ----------------------------------------- -- MESSAGE_POINTER : NODE; -- begin -- -- find the directory record and update the directory file -- RECORD_NUMBER := 1; OPEN (FILE_1, INOUT_FILE, "MSGDRCTRY.DAT", ""); while not END_OF_FILE (FILE_1) loop READ (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); if DIRECTORY_RECORD.MESSAGE_TYPE = DIRECTORY_POINTER.MESSAGE_TYPE then DIRECTORY_RECORD.NUMBER_OF_MESSAGES := DIRECTORY_RECORD.NUMBER_OF_MESSAGES + 1; NATURAL_IO.PUT (TO => DIRECTORY_RECORD.NUMBER_STRING, ITEM => DIRECTORY_RECORD.NUMBER_OF_MESSAGES); exit; else RECORD_NUMBER := RECORD_NUMBER + 1; end if; end loop; -- WRITE (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); CLOSE (FILE_1); -- -- open the message file -- OPEN (FILE_2, INOUT_FILE, DIRECTORY_RECORD.MESSAGE_FILENAME & ".MSG", ""); -- MESSAGE_RECORD_NUMBER := MESSAGE_IO.POSITIVE_COUNT ((DIRECTORY_RECORD.NUMBER_OF_MESSAGES) * 4 + 1); -- MESSAGE_DATA.CLASS := MESSAGE_TEXT.CLASS; MESSAGE_DATA.NUMBER_OF_LINES := MESSAGE_TEXT.NUMBER_OF_LINES; -- GET_THE_DATE (MONTH, DAY, YEAR); MESSAGE_DATA.MONTH := MONTH; MESSAGE_DATA.DAY := DAY; MESSAGE_DATA.YEAR := YEAR; -- -- write the message to disk, 25 lines per record -- MESSAGE_POINTER := MESSAGE_TEXT.HEAD; -- LINE_NUMBER := 1; for I in 1..MESSAGE_TEXT.NUMBER_OF_LINES loop MESSAGE_DATA.CONTENT (LINE_NUMBER) := MESSAGE_POINTER.TEXT_LINE; MESSAGE_POINTER := MESSAGE_POINTER.NEXT_LINE; LINE_NUMBER := LINE_NUMBER + 1; if LINE_NUMBER > 25 or I >= MESSAGE_TEXT.NUMBER_OF_LINES then LINE_NUMBER := 1; WRITE (FILE_2, MESSAGE_DATA, MESSAGE_RECORD_NUMBER); MESSAGE_RECORD_NUMBER := MESSAGE_RECORD_NUMBER + 1; if MESSAGE_RECORD_NUMBER >= MESSAGE_IO.POSITIVE_COUNT (((DIRECTORY_RECORD.NUMBER_OF_MESSAGES) + 1) * 4 + 1) then raise RECORD_ERROR; end if; end if; end loop; -- CLOSE (FILE_2); PROMPT("New message saved in data base"); -- exception -- when RECORD_ERROR => CLOSE (FILE_2); PROMPT ("Too many lines this message, only 100 lines saved"); -- end PUT_NEW_MESSAGE_IN; -- ---------------------------------------------- procedure PUT_OLD_MESSAGE_BACK_IN (DIRECTORY_POINTER : in DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL; MESSAGE_TEXT : in MESSAGE) is ---------------------------------------------- -- MESSAGE_POINTER : NODE; -- begin -- -- validate the message number -- if MESSAGE_NUMBER > DIRECTORY_POINTER.NUMBER_OF_MESSAGES then PROMPT ("illegal record number selected"); return; end if; -- -- open the message file -- OPEN (FILE_2, INOUT_FILE, DIRECTORY_POINTER.MESSAGE_FILENAME & ".MSG", ""); -- -- must be a valid selection, process it -- MESSAGE_RECORD_NUMBER := MESSAGE_IO.POSITIVE_COUNT (MESSAGE_NUMBER * 4 + 1); -- MESSAGE_DATA.CLASS := MESSAGE_TEXT.CLASS; MESSAGE_DATA.NUMBER_OF_LINES := MESSAGE_TEXT.NUMBER_OF_LINES; -- GET_THE_DATE (MONTH, DAY, YEAR); MESSAGE_DATA.MONTH := MONTH; MESSAGE_DATA.DAY := DAY; MESSAGE_DATA.YEAR := YEAR; -- -- write the message to disk, 25 lines per record -- MESSAGE_POINTER := MESSAGE_TEXT.HEAD; -- LINE_NUMBER := 1; for I in 1..MESSAGE_TEXT.NUMBER_OF_LINES loop MESSAGE_DATA.CONTENT (LINE_NUMBER) := MESSAGE_POINTER.TEXT_LINE; MESSAGE_POINTER := MESSAGE_POINTER.NEXT_LINE; LINE_NUMBER := LINE_NUMBER + 1; if LINE_NUMBER > 25 or I >= MESSAGE_TEXT.NUMBER_OF_LINES then LINE_NUMBER := 1; WRITE (FILE_2, MESSAGE_DATA, MESSAGE_RECORD_NUMBER); MESSAGE_RECORD_NUMBER := MESSAGE_RECORD_NUMBER + 1; if NATURAL (MESSAGE_RECORD_NUMBER) >= (MESSAGE_NUMBER + 1) * 4 + 1 then raise RECORD_ERROR; end if; end if; end loop; -- CLOSE (FILE_2); PROMPT("Old message restored in data base"); -- exception -- when RECORD_ERROR => CLOSE (FILE_2); PROMPT ("Too many lines this message, only 100 lines saved"); -- end PUT_OLD_MESSAGE_BACK_IN; -- -------------------------------------- procedure DELETE_MESSAGE_FROM_DATABASE (DIRECTORY_POINTER : in out DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL) is -------------------------------------- -- SCRATCH_MESSAGE : MESSAGE; ENTRY_NUMBER : NATURAL; -- begin -- -- validate the message number to be deleted -- if MESSAGE_NUMBER > DIRECTORY_POINTER.NUMBER_OF_MESSAGES or MESSAGE_NUMBER = 0 then PROMPT ("Illegal Message Delete Attempted"); return; -- else -- PROMPT ("Deleting Message Entry"); -- OPEN (FILE_1, INOUT_FILE, "MSGDRCTRY.DAT", ""); -- -- last entry deletion does not require repacking -- if MESSAGE_NUMBER /= DIRECTORY_POINTER.NUMBER_OF_MESSAGES then -- -- must re-pack the message file -- for I in MESSAGE_NUMBER + 1..DIRECTORY_POINTER.NUMBER_OF_MESSAGES loop ENTRY_NUMBER := NATURAL (I); GET_MESSAGE_OUT (DIRECTORY_POINTER, ENTRY_NUMBER, SCRATCH_MESSAGE); ENTRY_NUMBER := ENTRY_NUMBER - 1; PUT_OLD_MESSAGE_BACK_IN (DIRECTORY_POINTER, ENTRY_NUMBER, SCRATCH_MESSAGE); end loop; end if; -- RECORD_NUMBER := 1; while not END_OF_FILE (FILE_1) loop READ (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); exit when DIRECTORY_RECORD.MESSAGE_TYPE = DIRECTORY_POINTER.MESSAGE_TYPE; RECORD_NUMBER := RECORD_NUMBER + 1; end loop; -- DIRECTORY_RECORD.NUMBER_OF_MESSAGES := DIRECTORY_RECORD.NUMBER_OF_MESSAGES - 1; NATURAL_IO.PUT (TO => DIRECTORY_RECORD.NUMBER_STRING, ITEM => DIRECTORY_RECORD.NUMBER_OF_MESSAGES); WRITE (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); CLOSE (FILE_1); -- end if; -- end DELETE_MESSAGE_FROM_DATABASE; -- -- end FILE_ACCESS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --pp.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE PRINT_PROCEDURES -- -- File name : PP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TYPE_LIST; use TYPE_LIST; with FILE_ACCESS; use FILE_ACCESS; with LINKED_LIST_PROCEDURES; use LINKED_LIST_PROCEDURES; package PRINT_PROCEDURES is -- -- The print package provides the GMHF system routines with the -- capability of supplying hardcopy out-puts of single messages, -- groups of messages, and the message directory of the internal -- message database. -- -- procedure PRINT_MESSAGE_DIRECTORY; procedure PRINT_MESSAGE_TEXT (DIRECTORY_POINTER : DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL); procedure PRINT_MESSAGE_TEXT (WORKSPACE_MESSAGE : in MESSAGE; MESSAGE_TYPE : in AVAILABLE_TYPES); procedure PRINT_GROUP_OF_MESSAGES (DIRECTORY_POINTER : DIRECTORY_ENTRY; FIRST_MESSAGE, LAST_MESSAGE : in NATURAL); -- end PRINT_PROCEDURES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --pp.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE PRINT_PROCEDURES -- -- File name : PP.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with DIRECT_IO; with CALENDAR; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with CLASSIFICATION_DEFINITION; use CLASSIFICATION_DEFINITION; package body PRINT_PROCEDURES is -- -- The print package provides the GMHF system routines with the -- capability of supplying hardcopy out-puts of single messages, -- groups of messages, and the message directory of the internal -- message database. -- -- --------------------------------------------- -- local variables and package instantiations --------------------------------------------- -- FILE_2 : TEXT_IO.FILE_TYPE; -- package TYPE_IO is new TEXT_IO.ENUMERATION_IO (AVAILABLE_TYPES); package CLASS_IO is new TEXT_IO.ENUMERATION_IO (CLASSIFICATION); package NUMBER_IO is new INTEGER_IO (NATURAL); package TIME_IO is new INTEGER_IO (INTEGER); -- MONTH : INTEGER; DAY : INTEGER; YEAR : INTEGER; -- -- --------------------------------- -- routines local to this package --------------------------------- -- procedure GET_THE_DATE (MONTH, DAY, YEAR : out INTEGER) is -- COMPUTE_TIME : CALENDAR.TIME; -- begin -- COMPUTE_TIME := CALENDAR.CLOCK; -- MONTH := CALENDAR.MONTH (COMPUTE_TIME); DAY := CALENDAR.DAY (COMPUTE_TIME); YEAR := CALENDAR.YEAR (COMPUTE_TIME); -- end GET_THE_DATE; -- procedure PRINT_MESSAGE_HEADER (CLASS : in CLASSIFICATION; MESSAGE_TYPE : in AVAILABLE_TYPES; MESSAGE_NUMBER : NATURAL; MONTH, DAY, YEAR : in INTEGER) is -- begin -- PUT (FILE_2, ASCII.FF); -- PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); CLASS_IO.PUT (FILE_2, CLASS); PUT_LINE (FILE_2, " "); -- PUT (FILE_2, "Date Last Modified : "); TIME_IO.PUT (FILE_2, MONTH, 2); PUT (FILE_2, "/"); TIME_IO.PUT (FILE_2, DAY, 2); PUT (FILE_2, "/"); TIME_IO.PUT (FILE_2, YEAR, 4); -- PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, "Message Number : "); NUMBER_IO.PUT (FILE_2, MESSAGE_NUMBER); PUT_LINE (FILE_2, " "); -- PUT (FILE_2, "Message Type : "); TYPE_IO.PUT (FILE_2, MESSAGE_TYPE); -- PUT_LINE (FILE_2, " "); PUT_LINE (FILE_2, " "); -- end PRINT_MESSAGE_HEADER; -- procedure PRINT_MESSAGE_TRAILER (CLASS : in CLASSIFICATION) is -- begin -- PUT_LINE (FILE_2, " "); PUT_LINE (FILE_2, " "); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); CLASS_IO.PUT (FILE_2, CLASS); PUT_LINE (FILE_2, " "); -- end PRINT_MESSAGE_TRAILER; -- ------------------------------------ -- ------------------------------------ procedure PRINT_MESSAGE_DIRECTORY is ------------------------------------ -- DIRECTORY_RECORD : DIRECTORY_STRUCTURE; -- package DIR_IO is new DIRECT_IO (DIRECTORY_STRUCTURE); use DIR_IO; FILE_1 : DIR_IO.FILE_TYPE; DIRECTORY_RECORD_NUMBER : DIR_IO.POSITIVE_COUNT := 1; -- package INT_IO is new TEXT_IO.INTEGER_IO (INTEGER); -- -- begin -- -- inform user of action being taken -- PROMPT ("Printing the Message Directory"); -- -- open the directory file -- OPEN (FILE_1, INOUT_FILE, "MSGDRCTRY.DAT", ""); -- -- open the print file -- OPEN (FILE_2, OUT_FILE, "SYS$PRINT:", ""); -- -- print header -- PUT (FILE_2, ASCII.FF); PUT_LINE (FILE_2, " "); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, "GMHF DIRECTORY LISTING"); PUT_LINE (FILE_2, " "); PUT (FILE_2, ASCII.HT); PUT (FILE_2, " Message Type"); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, " File Name"); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, " No. Messages"); PUT_LINE (FILE_2, " "); PUT_LINE (FILE_2, " "); -- -- loop till end of file -- while not END_OF_FILE (FILE_1) loop READ (FILE_1, DIRECTORY_RECORD, DIRECTORY_RECORD_NUMBER); -- PUT (FILE_2, ASCII.HT); TYPE_IO.PUT (FILE_2, DIRECTORY_RECORD.MESSAGE_TYPE); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); PUT (FILE_2, DIRECTORY_RECORD.MESSAGE_FILENAME); PUT (FILE_2, ASCII.HT); PUT (FILE_2, ASCII.HT); INT_IO.PUT (FILE_2, DIRECTORY_RECORD.NUMBER_OF_MESSAGES); PUT_LINE (FILE_2, " "); -- DIRECTORY_RECORD_NUMBER := DIRECTORY_RECORD_NUMBER + 1; end loop; -- -- close the files CLOSE (FILE_1); CLOSE (FILE_2); -- end PRINT_MESSAGE_DIRECTORY; -- ----------------------------- procedure PRINT_MESSAGE_TEXT (DIRECTORY_POINTER : DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL) is ----------------------------- -- LINE_NUMBER : INTEGER := 1; -- -- internal message structure -- type MESSAGE_FORMAT is array (1..25) of STRING (1..80); type MESSAGE_RECORD is record CLASS : CLASSIFICATION; NUMBER_OF_LINES : POSITIVE; MONTH, DAY, YEAR : INTEGER; CONTENT : MESSAGE_FORMAT; end record; -- package MESSAGE_IO is new DIRECT_IO (MESSAGE_RECORD); use MESSAGE_IO; FILE_3 : MESSAGE_IO.FILE_TYPE; RECORD_NUMBER : MESSAGE_IO.POSITIVE_COUNT; -- MESSAGE_DATA : MESSAGE_RECORD; -- -- begin -- -- inform the operator of the action being taken -- if MESSAGE_NUMBER > 0 then PROMPT ("Printing Message Text"); else PROMPT ("Printing the Prototype Message Text"); end if; -- -- open the message file -- OPEN (FILE_3, INOUT_FILE, DIRECTORY_POINTER.MESSAGE_FILENAME & ".MSG", ""); -- -- open the print file -- OPEN (FILE_2, OUT_FILE, "SYS$PRINT:", ""); -- -- read the first message record, read more records as needed -- RECORD_NUMBER := MESSAGE_IO.POSITIVE_COUNT (MESSAGE_NUMBER * 3 + 1); -- READ (FILE_3, MESSAGE_DATA, RECORD_NUMBER); -- -- print the message header and classification -- PRINT_MESSAGE_HEADER (MESSAGE_DATA.CLASS, DIRECTORY_POINTER.MESSAGE_TYPE, MESSAGE_NUMBER, MESSAGE_DATA.MONTH, MESSAGE_DATA.DAY, MESSAGE_DATA.YEAR); -- for I in 1..MESSAGE_DATA.NUMBER_OF_LINES loop -- if LINE_NUMBER > 25 then LINE_NUMBER := 1; RECORD_NUMBER := RECORD_NUMBER + 1; READ (FILE_3, MESSAGE_DATA, RECORD_NUMBER); end if; -- PUT (FILE_2, MESSAGE_DATA.CONTENT (LINE_NUMBER)); PUT_LINE (FILE_2, " "); LINE_NUMBER := LINE_NUMBER + 1; -- -- check to see if a page is full, if so need trailer & header -- if I = 50 then PRINT_MESSAGE_TRAILER (MESSAGE_DATA.CLASS); PRINT_MESSAGE_HEADER (MESSAGE_DATA.CLASS, DIRECTORY_POINTER.MESSAGE_TYPE, MESSAGE_NUMBER, MONTH, DAY, YEAR); end if; -- end loop; -- -- trailing classification -- PRINT_MESSAGE_TRAILER (MESSAGE_DATA.CLASS); -- -- close the files -- CLOSE (FILE_2); CLOSE (FILE_3); -- end PRINT_MESSAGE_TEXT; -- ------------------------------- procedure PRINT_MESSAGE_TEXT (WORKSPACE_MESSAGE : in MESSAGE; MESSAGE_TYPE : in AVAILABLE_TYPES) is ------------------------------- -- CURRENT_LINE : NODE; -- begin -- CURRENT_LINE := WORKSPACE_MESSAGE.HEAD; -- PROMPT ("Printing the workspace Message Text"); -- -- open the print file -- OPEN (FILE_2, OUT_FILE, "SYS$PRINT:", ""); -- -- get the current date -- GET_THE_DATE (MONTH, DAY, YEAR); -- -- print the message header and classification -- PRINT_MESSAGE_HEADER (WORKSPACE_MESSAGE.CLASS, MESSAGE_TYPE, 0, MONTH, DAY, YEAR); -- for I in 1..WORKSPACE_MESSAGE.NUMBER_OF_LINES loop -- PUT (FILE_2, CURRENT_LINE.TEXT_LINE); PUT_LINE (FILE_2, " "); CURRENT_LINE := CURRENT_LINE.NEXT_LINE; -- -- check to see if a page is full, if so need trailer & header -- if I = 50 then PRINT_MESSAGE_TRAILER (WORKSPACE_MESSAGE.CLASS); PRINT_MESSAGE_HEADER (WORKSPACE_MESSAGE.CLASS, MESSAGE_TYPE, 0, MONTH, DAY, YEAR); end if; -- end loop; -- -- trailing classification -- PRINT_MESSAGE_TRAILER (WORKSPACE_MESSAGE.CLASS); -- -- close the file -- CLOSE (FILE_2); -- end PRINT_MESSAGE_TEXT; -- ---------------------------------- procedure PRINT_GROUP_OF_MESSAGES (DIRECTORY_POINTER : DIRECTORY_ENTRY; FIRST_MESSAGE, LAST_MESSAGE : in NATURAL) is ---------------------------------- -- START_OF_LOOP : NATURAL; END_OF_LOOP : NATURAL; -- begin -- -- validate the message numbers -- START_OF_LOOP := FIRST_MESSAGE; END_OF_LOOP := LAST_MESSAGE; -- if LAST_MESSAGE < FIRST_MESSAGE then START_OF_LOOP := LAST_MESSAGE; END_OF_LOOP := FIRST_MESSAGE; end if; -- if END_OF_LOOP > DIRECTORY_POINTER.NUMBER_OF_MESSAGES then END_OF_LOOP := DIRECTORY_POINTER.NUMBER_OF_MESSAGES; end if; -- for I in START_OF_LOOP..END_OF_LOOP loop PRINT_MESSAGE_TEXT (DIRECTORY_POINTER, I); end loop; -- end PRINT_GROUP_OF_MESSAGES; -- end PRINT_PROCEDURES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --edittypes.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE EDITOR_TYPES -- -- File name : EDITTYPES.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with DIRECT_IO; with TEXT_IO; use TEXT_IO; with LINKED_LIST_PROCEDURES; use LINKED_LIST_PROCEDURES; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; package EDITOR_TYPES is package INT_IO is new INTEGER_IO (INTEGER); -- here we define the structures used to define the manner in which -- lines are composed of fields -- -- the type line_component defines how a field is used within -- a line. Each line will be an array of line_component. The user -- specifies each field which is in the line, its position and -- length, and whether it is required. -- type LINE_COMPONENT is record FIELD : INTEGER; FIELD_POSITION : INTEGER; FIELD_LENGTH : INTEGER; REQUIRED : BOOLEAN; end record; -- -- we define a line as an array of line components. this allows -- the structure of each type of line to be specified in terms of -- basic building blocks - line_component's. A line structure -- specification consists of the number of fields, a prototype -- version of the line, and an array of the line_component's which -- define its fields. the prototype line contains all -- non-changeable characters in their normal positions, with all -- user changeable characters left as blanks. It is in some sense -- a 'blank line' ready to be filled in. -- -- THE 34 IS A KLUDGE vv this should be max flds/line type COMPONENT_ARRAY is array (1..34) of LINE_COMPONENT; -- type LINE_DEFINITION is record NUMBER_OF_FIELDS : INTEGER; PROTOTYPE_LINE : LINE_OF_TEXT; COMPONENT : COMPONENT_ARRAY; end record; type LINE_DEFINITION_ARRAY is array (0..34) of LINE_DEFINITION; package LINE_DEFINITION_IO is new DIRECT_IO (LINE_DEFINITION); -- -- The structures of the lines being implemented are stored in a -- file passed as a formal parameter. Below we define the entities -- required to open and read that file. -- LINE_STRUCTURE_FILE : LINE_DEFINITION_IO.FILE_TYPE; LINE_TYPE_COUNTER : LINE_DEFINITION_IO.POSITIVE_COUNT; -- -- now we define those data types and file structures required to -- hold and access field prompts and amplifications. This works as -- follows: -- each type of field has a 'field prompt' which appears under -- it in the work area. Some fields have amplifying information -- which appears in the amp area. These data are held in a -- direct access file supplied by the implementor. In addition, -- since lines contain the fields in varying order, there is an -- accompanying 'lookup array' which holds the prompt numbers -- for each field of a line. Thus to display a prompt, you tell -- display_prompt what line type is being edited, which field, -- and so on, and it retrieves the appropriate field prompt and -- amp and displays them. -- subtype PROMPT_DISPLAY_LINE is STRING (1..NMBR_OF_COLS); MAXIMUM_AMP_LINES : INTEGER := BOT_OF_AMP_AREA - TOP_OF_AMP_AREA + 1; type AMP_LINE_DATA is record AMP_POSITION : CRT_POSITION; AMP_LINE : PROMPT_DISPLAY_LINE; end record; type AMP_INFORMATION is array (1..MAXIMUM_AMP_LINES) of AMP_LINE_DATA; type PROMPT_DATA is record LENGTH_OF_FIELD_PROMPT : INTEGER; FIELD_PROMPT : PROMPT_DISPLAY_LINE; NUMBER_OF_AMP_LINES : INTEGER range 0..MAXIMUM_AMP_LINES; THIS_AMP : AMP_INFORMATION; end record; package FIELD_PROMPT_IO is new DIRECT_IO (PROMPT_DATA); FIELD_PROMPT_FILE : FIELD_PROMPT_IO.FILE_TYPE; -- 34 is a major kludge type FIELD_PROMPT_VECTOR is array (1..34) of NATURAL; CURRENT_PROMPTS : FIELD_PROMPT_VECTOR; CURRENT_LINE : INTEGER; package PROMPT_VECTOR_IO is new DIRECT_IO (FIELD_PROMPT_VECTOR); PROMPT_VECTOR_FILE : PROMPT_VECTOR_IO.FILE_TYPE; PROMPT_COUNT : PROMPT_VECTOR_IO.POSITIVE_COUNT; package FIELD_PROMPT is procedure DISPLAY_PROMPT (LINE_NUMBER : in NATURAL; FIELD_NUMBER : in POSITIVE; FIELD_POSITION : in POSITIVE; FIELD_LENGTH : in POSITIVE; ANY_AMP : out BOOLEAN); procedure DISPLAY_PROMPT (SPECIAL_PROMPT_NUMBER : in POSITIVE); end FIELD_PROMPT; -- -- These provide the default procedures for generic instantiation. -- procedure NULL_PROCEDURE (LINE_TO_PACK : in out LINE_OF_TEXT; LINE_FORMAT : in LINE_DEFINITION); procedure NULL_PROCEDURE; end EDITOR_TYPES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --edittypes.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE EDITOR_TYPES -- -- File name : EDITTYPES.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; package body EDITOR_TYPES is package body FIELD_PROMPT is FIRST_TIME_DISPLAYED : BOOLEAN := FALSE; procedure RETRIEVE_PROMPT (LINE_NUMBER : in INTEGER; FIELD_NUMBER : in INTEGER; PROMPT : out PROMPT_DATA) is RECORD_NUMBER : NATURAL; ITEM_COUNT : FIELD_PROMPT_IO.POSITIVE_COUNT; begin -- -- If the look-up array has not yet been updated for this line -- then read it. -- if CURRENT_LINE /= LINE_NUMBER or FIRST_TIME_DISPLAYED = FALSE then PROMPT_COUNT := PROMPT_VECTOR_IO.POSITIVE_COUNT (LINE_NUMBER + 1); PROMPT_VECTOR_IO.READ (PROMPT_VECTOR_FILE, CURRENT_PROMPTS, PROMPT_COUNT); FIRST_TIME_DISPLAYED := TRUE; end if; -- -- Use the look-up array to determine which prompt to display -- RECORD_NUMBER := CURRENT_PROMPTS (FIELD_NUMBER); -- -- here we do a direct access read on the prompt file - -- field prompt and amplification -- ITEM_COUNT := FIELD_PROMPT_IO.POSITIVE_COUNT (RECORD_NUMBER); FIELD_PROMPT_IO.READ (FIELD_PROMPT_FILE, PROMPT, ITEM_COUNT); -- end RETRIEVE_PROMPT; procedure DISPLAY_PROMPT (LINE_NUMBER : in NATURAL; FIELD_NUMBER : in POSITIVE; FIELD_POSITION : in POSITIVE; FIELD_LENGTH : in POSITIVE; ANY_AMP : out BOOLEAN) is PROMPT : PROMPT_DATA; OFFSET : INTEGER; DASH_LINE : LINE_OF_TEXT := (1..80 => '-'); begin -- -- first retrieve the two pieces of the prompt - the field -- prompt and the amplification -- RETRIEVE_PROMPT (LINE_NUMBER, FIELD_NUMBER, PROMPT); if PROMPT.NUMBER_OF_AMP_LINES = 0 then ANY_AMP := FALSE; else ANY_AMP := TRUE; end if; CURRENT_LINE := LINE_NUMBER; -- -- now position the cursor and underline the field -- GOTO_CRT_POSITION (BOT_OF_WORK_AREA - 1, FIELD_POSITION); PUT (DASH_LINE (1..FIELD_LENGTH)); -- -- first figure out the offset for the field prompt, -- then position the cursor and write the field prompt -- OFFSET_BLOCK : -- -- The point of this block is to determine where to start -- writing the propmt in order that it be as centered as -- possible under the field -- declare LENGTH_DELTA, HALF_DELTA, EXCESS, UNDERAGE : INTEGER; begin LENGTH_DELTA := FIELD_LENGTH - PROMPT.LENGTH_OF_FIELD_PROMPT; HALF_DELTA := LENGTH_DELTA / 2; if LENGTH_DELTA >= 0 then -- here prompt shorter than field OFFSET := HALF_DELTA; else -- here field shorter than prompt EXCESS := FIELD_POSITION + FIELD_LENGTH + abs (HALF_DELTA) + 1 - NMBR_OF_COLS; UNDERAGE := FIELD_POSITION - abs (HALF_DELTA) - 1; GOTO_CRT_POSITION (22, 1); if EXCESS <= 0 and UNDERAGE >= 0 then OFFSET := HALF_DELTA; elsif EXCESS > 0 then OFFSET := HALF_DELTA - EXCESS; else OFFSET := HALF_DELTA + abs (UNDERAGE); end if; end if; end OFFSET_BLOCK; GOTO_CRT_POSITION (BOT_OF_WORK_AREA, FIELD_POSITION + OFFSET); PUT (PROMPT.FIELD_PROMPT); -- -- now write the amplification -if any; number of lines is often 0 -- for I in 1..PROMPT.NUMBER_OF_AMP_LINES loop GOTO_CRT_POSITION (PROMPT.THIS_AMP (I).AMP_POSITION); PUT (PROMPT.THIS_AMP (I).AMP_LINE); end loop; end DISPLAY_PROMPT; procedure RETRIEVE_PROMPT (SPECIAL_PROMPT_NUMBER : in POSITIVE; PROMPT : out PROMPT_DATA) is RECORD_NUMBER : NATURAL; ITEM_COUNT : FIELD_PROMPT_IO.POSITIVE_COUNT; begin -- -- If the look-up array has not yet been updated for this line -- then read it. -- if CURRENT_LINE /= 0 or FIRST_TIME_DISPLAYED = FALSE then PROMPT_COUNT := PROMPT_VECTOR_IO.POSITIVE_COUNT (1); PROMPT_VECTOR_IO.READ (PROMPT_VECTOR_FILE, CURRENT_PROMPTS, PROMPT_COUNT); FIRST_TIME_DISPLAYED := TRUE; end if; RECORD_NUMBER := CURRENT_PROMPTS (SPECIAL_PROMPT_NUMBER); -- -- here we do a direct access read on the prompt file- amp only -- ITEM_COUNT := FIELD_PROMPT_IO.POSITIVE_COUNT (RECORD_NUMBER); FIELD_PROMPT_IO.READ (FIELD_PROMPT_FILE, PROMPT, ITEM_COUNT); end RETRIEVE_PROMPT; procedure DISPLAY_PROMPT (SPECIAL_PROMPT_NUMBER : in POSITIVE) is PROMPT : PROMPT_DATA; begin -- -- first retrieve the prompt -- RETRIEVE_PROMPT (SPECIAL_PROMPT_NUMBER, PROMPT); CURRENT_LINE := 0; -- -- now write the amplification -- for I in 1..PROMPT.NUMBER_OF_AMP_LINES loop GOTO_CRT_POSITION (PROMPT.THIS_AMP (I).AMP_POSITION); PUT (PROMPT.THIS_AMP (I).AMP_LINE); end loop; end DISPLAY_PROMPT; end FIELD_PROMPT; procedure NULL_PROCEDURE (LINE_TO_PACK : in out LINE_OF_TEXT; LINE_FORMAT : in LINE_DEFINITION) is begin null; end NULL_PROCEDURE; procedure NULL_PROCEDURE is begin null; end NULL_PROCEDURE; end EDITOR_TYPES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --genfile.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE FILE_GENERIC -- -- File name : GENFILE.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with EDITOR_TYPES; use EDITOR_TYPES; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with LINKED_LIST_PROCEDURES; use LINKED_LIST_PROCEDURES; package FILE_GENERIC is -- this generic definition reads the line structure from a file -- which is passed as a generic parameter generic -- -- the first three parameters allow the implementor to specify -- limits on message line characteristics. -- MAXIMUM_FIELDS_PER_LINE, MAXIMUM_CHARACTERS_PER_LINE, MAXIMUM_LINES_PER_MESSAGE : POSITIVE; -- -- the implementor must specify the legal line and field names, -- as well as the name of the files which contain the line -- structure definitions and the field prompts. -- type LINE_NAME is (<> ); -- with procedure GET_LINE_NAME (LINE_TYPE : out LINE_NAME) is <>; -- type FIELD_NAME is (<> ); -- and the legal field names. -- LINE_STRUCTURE_FILE_NAME : STRING; -- PROMPT_VECTOR_FILE_NAME : STRING; --holds lookup table for field pmts -- FIELD_PROMPT_FILE_NAME : STRING; -- holds field prompts themselves -- -- get_field is provided by the implementor for each instantiation. -- in some cases, the same get_field could be used for different -- message types. this would be possible if the message types -- differed only at the line level, and not at the field level. -- an example is the different colors of Rainform messages. the -- different colors require different combinations of lines, but -- use the same field structures. -- with procedure GET_FIELD (FIELD_TYPE : in FIELD_NAME; FIELD_GOTTEN : in out STRING; FIELD_POSITION : in POSITIVE; FIELD_LENGTH : in POSITIVE; COMMAND_GOTTEN : in out COMMAND; COMMAND_FLAG : in out BOOLEAN) is <>; -- -- some line formats require extraneous blanks to be removed from -- fields, while other line formats make no such requirements. To -- handle either case, we define procedures pack_line & unpack_line. -- the defaults for these procedures are null routines, but the -- implementor may substitute a non-null procedure as a formal -- parameter, as we have done in the Rainform instance. pack_line -- removes extraneous blanks, while unpack_line expands a packed line -- as specified by the line format requirements. -- with procedure PACK_LINE (LINE_TO_PACK : in out LINE_OF_TEXT; LINE_FORMAT : in LINE_DEFINITION) is NULL_PROCEDURE; with procedure UNPACK_LINE (LINE_TO_UNPACK : in out LINE_OF_TEXT; LINE_FORMAT : in LINE_DEFINITION) is NULL_PROCEDURE; -- -- -- validate_line_insertion allows the user to specify any conditions -- to be placed upon the insertion of lines into messages. -- For example, it may be that a line of some particular type must be -- preceded by a line of some other type; in such a case, this -- routine would ensure that the requirement was met, or if not met, -- it would perform the user specified action. -- with procedure VALIDATE_LINE_INSERTION is NULL_PROCEDURE; -- -- parse_line_type is required to parse the message lines, determine -- the line type of each line of the message, and place that line -- type in the appropriate field of the message component for that -- line. -- with procedure PARSE_LINE_TYPE (POINTER_TO_LINE : NODE; LINE_TYPE_FOUND : out LINE_NAME); package FILED_GENERIC_MESSAGE_EDITOR is -- -- variables defined here are used in the main edit procedure below. -- LENGTH_OF_FIELD : INTEGER; -- length of the current field START_OF_FIELD : INTEGER; -- starting position of the current field END_OF_FIELD : INTEGER; -- ending position of the current field BLANK_LINE : LINE_OF_TEXT := (1..80 => ' '); -- for blank filling LINE_FORMAT : LINE_DEFINITION; -- to hold format of the current line CHAR : STRING (1..1); USER_INPUT : COMMAND; TEMP_LINE_TYPE : LINE_NAME; -- the next three temporarys are to allow TEMP_FIELD_TYPE : FIELD_NAME; -- us to keep references to line( ).xxx TEMP_INTEGER : INTEGER; -- on one line. LINE_STRUCTURE_FILE : LINE_DEFINITION_IO.FILE_TYPE; LINE_TYPE_COUNTER : LINE_DEFINITION_IO.POSITIVE_COUNT; TEMP_AMP : BOOLEAN; -- -- working_data is a record definition which defines those data -- required to change the contents of a message during its editing -- process. This includes the message being edited, -- a pointer to and the relative line number in -- the message of: the top line currently displayed, the bottom -- line currently displayed, and the current line being edited; a -- flag which tracks whether the use of the current line is valid, -- the number of the field being edited; we keep track of whether -- the editor is in scroll mode (vs edit mode) and whether any -- changes have yet been made to the message being edited. Finally -- a 'buffer' for the next command to be executed is provided. -- -- the type line_information is defined to hold the pointers and -- relative line numbers mentioned above. -- type LINE_INFORMATION is record LINE_NUMBER : INTEGER range 1..MAXIMUM_LINES_PER_MESSAGE; LINE_POINTER : NODE; end record; -- -- the discrete type edit_mode is used to track whether the user -- is in scroll mode or edit mode. -- type EDIT_MODE is (SCROLL, EDIT ); -- type WORKING_DATA is record CURRENT_MESSAGE : MESSAGE; -- the message being edited WORK_LINE : LINE_INFORMATION; -- number & ptr to the current line TOP_LINE : LINE_INFORMATION; -- number & ptr to the top line BOTTOM_LINE : LINE_INFORMATION; -- number & ptr to the bottom line VALIDATED_LINE_FLAG : BOOLEAN; -- is this line valid CURRENT_FIELD : INTEGER range 1..MAXIMUM_FIELDS_PER_LINE; -- field currently being edited ANY_AMP : BOOLEAN; -- is there an amp for the current field prompt MODE : EDIT_MODE; -- edit mode or scroll mode CHANGES_MADE_FLAG : BOOLEAN; -- made any changes to this message NEXT_COMMAND : COMMAND; -- next command entered by user end record; -- WD : WORKING_DATA; procedure EDITOR (MESSAGE_PASSED : in out MESSAGE); -- end FILED_GENERIC_MESSAGE_EDITOR; end FILE_GENERIC; ------------------------------------------------------------------------ with TEXT_IO; use TEXT_IO; with CLASSIFICATION_DEFINITION; use CLASSIFICATION_DEFINITION; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with FILE_ACCESS; use FILE_ACCESS; package body FILE_GENERIC is package body FILED_GENERIC_MESSAGE_EDITOR is procedure EDITOR (MESSAGE_PASSED : in out MESSAGE) is -- -- Here we define those edit functions which are independent of -- message type, except possibly for formal data parameters. -- ------------------------------------- procedure FILL_LINE_TYPES is ------------------------------------- LINE_TYPE_FOUND : LINE_NAME; LINE_TO_PARSE : NODE; begin -- -- we proceed from head to tail of the message in msg, and -- for each line, we deterime the line type using parse_line_type. -- we then determine the position of that line type in the type -- line_name, and store the position in the line_type field of the -- message component. In fact, we consider the set of positions to -- range between 1..number of line types rather than 0..(number of -- line types - 1). -- if MESSAGE_PASSED.NUMBER_OF_LINES < 1 then return; end if; -- LINE_TO_PARSE := MESSAGE_PASSED.HEAD; for I in 1..MESSAGE_PASSED.NUMBER_OF_LINES loop PARSE_LINE_TYPE (LINE_TO_PARSE, LINE_TYPE_FOUND); LINE_TO_PARSE.LINE_TYPE := LINE_NAME'POS (LINE_TYPE_FOUND) + 1; LINE_TO_PARSE := LINE_TO_PARSE.NEXT_LINE; end loop; -- end FILL_LINE_TYPES; -- ------------------------------------- procedure DISPLAY_LINE (LINE_DATA : LINE_INFORMATION; BACKLIGHT_FLAG : BOOLEAN) is ------------------------------------- CHARS_TO_DISPLAY, ROW : POSITIVE; begin -- -- if line is to be backlit then turn on reverse video -- if BACKLIGHT_FLAG = TRUE then REVERSE_VIDEO_ON; end if; -- -- calculate the row upon which we are to write the line, -- and position the cursor to the beginning of that row -- ROW := LINE_DATA.LINE_NUMBER - WD.TOP_LINE.LINE_NUMBER + TOP_OF_MESSAGE_AREA; GOTO_CRT_POSITION (ROW, 1); -- -- display the line, and reposition the cursor to the beginning -- of that line. Do this by first calculating the number of non -- blank characters. Display them. If backlight_flag is on, -- off reverse video. Then fill the remainder of the line with -- blanks (to over-write anything that might have been there -- before). -- for I in reverse 1..MAXIMUM_CHARACTERS_PER_LINE loop if LINE_DATA.LINE_POINTER.TEXT_LINE (I) /= ' ' then CHARS_TO_DISPLAY := I; exit; end if; end loop; PUT (LINE_DATA.LINE_POINTER.TEXT_LINE (1..CHARS_TO_DISPLAY)); -- -- if line was backlit then turn off reverse video -- if BACKLIGHT_FLAG = TRUE then REVERSE_VIDEO_OFF; end if; PUT (BLANK_LINE (1..MAXIMUM_CHARACTERS_PER_LINE - CHARS_TO_DISPLAY)); GOTO_CRT_POSITION (ROW, 1); end DISPLAY_LINE; -- ------------------------------------- procedure DISPLAY_MESSAGE is ------------------------------------- -- -- this routine displays message text lines in the message area. -- it displays starting with top_line and ending with bottom_line -- DISPLAY_LINE_POINTER : NODE; -- points to line being displayed NUMBER_OF_LINES_TO_DISPLAY : POSITIVE; begin -- -- first we initialize display_line_pointer and calculate the -- number of lines to display. -- then we loop, displaying lines and updating pointers. -- DISPLAY_LINE_POINTER := WD.TOP_LINE.LINE_POINTER; NUMBER_OF_LINES_TO_DISPLAY := WD.BOTTOM_LINE.LINE_NUMBER - WD.TOP_LINE.LINE_NUMBER + 1; -- for I in 1..NUMBER_OF_LINES_TO_DISPLAY loop -- -- position cursor, put text, and update pointer. -- GOTO_CRT_POSITION (TOP_OF_MESSAGE_AREA + I - 1, 1); PUT (DISPLAY_LINE_POINTER.TEXT_LINE (1..MAXIMUM_CHARACTERS_PER_LINE)); DISPLAY_LINE_POINTER := DISPLAY_LINE_POINTER.NEXT_LINE; end loop; DISPLAY_LINE (WD.WORK_LINE, TRUE); -- end DISPLAY_MESSAGE; -- ------------------------------------- procedure FIELD_PUT (FIELD_NUM : POSITIVE) is ------------------------------------- -- -- this routine determines the field type from the current field -- number and the working line type. it gets a string to display. -- it underlines the field, displays the string (the field prompt) -- and positions the cursor to the first position in the field. -- begin GOTO_CRT_POSITION (TOP_OF_WORK_AREA + 1, 1); ERASE_LINE; GOTO_CRT_POSITION (TOP_OF_WORK_AREA + 2, 1); ERASE_LINE; if WD.ANY_AMP = TRUE then GOTO_CRT_POSITION (TOP_OF_AMP_AREA, 1); ERASE_TO_END_OF_SCREEN; end if; -- -- now display the field prompt itself -- FIELD_PROMPT.DISPLAY_PROMPT (WD.WORK_LINE.LINE_POINTER.LINE_TYPE, WD.CURRENT_FIELD, LINE_FORMAT.COMPONENT (WD.CURRENT_FIELD).FIELD_POSITION, LINE_FORMAT.COMPONENT (WD.CURRENT_FIELD).FIELD_LENGTH, TEMP_AMP); -- -- now redisplay the classification and reposition to first -- character of field. Save the temp_amp flag. -- if TEMP_AMP = TRUE or WD.ANY_AMP = TRUE then DISPLAY_LOWER_CLASSIFICATION (WD.CURRENT_MESSAGE.CLASS); end if; WD.ANY_AMP := TEMP_AMP; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, LINE_FORMAT.COMPONENT (WD.CURRENT_FIELD).FIELD_POSITION); -- end FIELD_PUT; -- ------------------------------------- procedure GET_LINE_TYPE (LINE_TYPE : out LINE_NAME) is ------------------------------------- -- -- prompts the user with the names of lines available -- and accepts the user's input -- begin -- -- first we must prompt the user as to what line types are -- available. This prompt should be stored as an amp in the -- amp file. The actual parameter 1 in the display_prompt -- call tells display_prompt that it is the line_name prompt -- that is desired. -- ERASE_SCREEN; FIELD_PROMPT.DISPLAY_PROMPT (1); GOTO_CRT_POSITION (BOT_OF_AMP_AREA, NMBR_OF_COLS - 10); -- -- now ask for user entry, accept it, and return -- GET_LINE_NAME (LINE_TYPE); -- -- now re-display the menu & classification; -- DISPLAY_MENU ("editmenu"); DISPLAY_CLASSIFICATION (WD.CURRENT_MESSAGE.CLASS); end GET_LINE_TYPE; -- ------------------------------------- procedure START_END_AND_LENGTH (FIELD_NUMBER : INTEGER) is ------------------------------------- begin -- -- This is just to enhance readibility. It will -- determine starting position, length, and ending position -- of the field number passed -- START_OF_FIELD := LINE_FORMAT.COMPONENT (FIELD_NUMBER).FIELD_POSITION; -- LENGTH_OF_FIELD := LINE_FORMAT.COMPONENT (FIELD_NUMBER).FIELD_LENGTH; -- END_OF_FIELD := START_OF_FIELD + LENGTH_OF_FIELD - 1; -- end START_END_AND_LENGTH; -- ------------------------------------- procedure PROCESS_CLASSIFY_MESSAGE_COMMAND is ------------------------------------- begin -- -- To process the classify_message command, we first erase the -- bottom of the screen and display the prompt which solicits the -- desired classification. We then accept the user's entry. -- Finally, we erase the prompt and display the (new) -- classification. -- GOTO_CRT_POSITION (TOP_OF_AMP_AREA, 1); ERASE_TO_END_OF_SCREEN; FIELD_PROMPT.DISPLAY_PROMPT (2); GOTO_CRT_POSITION (TOP_OF_AMP_AREA + 3, 40); GET_CLASSIFICATION (WD.CURRENT_MESSAGE.CLASS); GOTO_CRT_POSITION (TOP_OF_AMP_AREA, 1); ERASE_TO_END_OF_SCREEN; DISPLAY_CLASSIFICATION (WD.CURRENT_MESSAGE.CLASS); end PROCESS_CLASSIFY_MESSAGE_COMMAND; -- -------------------------------------- procedure PROCESS_EDIT_LINE_COMMAND is -------------------------------------- -- -- process_edit_line_command encapsulates all functions required -- to edit a line. various data elements are defined below, and -- several procedures are also defined within the scope of this -- procedure. -- -- FIELD_GOTTEN : LINE_OF_TEXT; -- holds field entered by user COMMAND_GOTTEN : COMMAND; -- holds command entered by user COMMAND_FLAG : BOOLEAN; --flag specifying whether user gave cmd FIELD_TYPE : FIELD_NAME; -- kind of field to input WORKING_TEXT : LINE_OF_TEXT; -- working line of text -- ------------------------------------- procedure LINE_VALIDATE is ------------------------------------- --checks to ensure all required flds are non-null. It does this -- by comparing the current field contents with the prototype -- field contents. If they are the same, then by definition the -- field is empty. -- builds a prompt string listing the #s of any required fields -- which are not filled in. This string is initialized with a -- partial prompt - "required fields left blank:" - to which we -- concatenate the field number of each required field which is -- blank. If it turns out that a required field was left blank, -- we issue the prompt. -- PROMPT_STRING : STRING (1..NMBR_OF_COLS) := (1..NMBR_OF_COLS => ' '); RET_STR : STRING (1..5); T_STR, NUM_CHARS : INTEGER; P_STR_POINTER : INTEGER := 27; -- begin -- -- any line with no fields is valid -- if LINE_FORMAT.NUMBER_OF_FIELDS = 0 then return; end if; PROMPT_STRING (1..27) := "required fields left blank:"; -- -- initialize validated_line_flag to false. If the line is -- invalid by virtue of having a required field unfilled, -- set it to true. -- WD.VALIDATED_LINE_FLAG := FALSE; -- -- we compare the contents of each required field in the --current line with corresponding prototype field.if they're -- the same, the current field is empty (by definition). --In that case, we add that line's line number to the prompt -- we are building. -- for I in 1..LINE_FORMAT.NUMBER_OF_FIELDS loop -- if LINE_FORMAT.COMPONENT (I).REQUIRED = TRUE then -- -- this field is required. is it filled ? -- first determine start and end positions of field -- START_END_AND_LENGTH (I); -- -- now compare contents of prototype field to actual -- field. if they're the same, set flag and add to the -- prompt -- if WORKING_TEXT (START_OF_FIELD..END_OF_FIELD) = LINE_FORMAT.PROTOTYPE_LINE (START_OF_FIELD..END_OF_FIELD) then -- WD.VALIDATED_LINE_FLAG := TRUE; -- -- convert the field number (i) to a string -- INT_STR (I, RET_STR, NUM_CHARS); -- -- set temp prompt string length to old prompt -- string length + number of characters in latest -- field # + 2. if the temp length can be -- accomodated by crt width,then adjust the prompt -- and the prompt length. -- T_STR := P_STR_POINTER + NUM_CHARS + 2; -- if T_STR <= NMBR_OF_COLS then PROMPT_STRING (P_STR_POINTER + 1..T_STR) := " " & RET_STR (1..NUM_CHARS) & ","; P_STR_POINTER := T_STR; end if; end if; end if; end loop; -- -- if there was a required field left blank, prompt the user -- if WD.VALIDATED_LINE_FLAG = TRUE then PROMPT (PROMPT_STRING); end if; -- end LINE_VALIDATE; -- ------------------------------------- procedure PROCESS_NEXT_FIELD_COMMAND is ------------------------------------- begin -- -- if we are at end of line set field pointer to 1, -- otherwise increment it. -- -- if WD.CURRENT_FIELD = LINE_FORMAT.NUMBER_OF_FIELDS then WD.CURRENT_FIELD := 1; else WD.CURRENT_FIELD := WD.CURRENT_FIELD + 1; end if; -- -- determine new field type -- FIELD_TYPE := FIELD_NAME'VAL (LINE_FORMAT.COMPONENT (WD.CURRENT_FIELD).FIELD); -- -- put the field prompt to the screen and position cursor -- FIELD_PUT (WD.CURRENT_FIELD); -- end PROCESS_NEXT_FIELD_COMMAND; -- ------------------------------------- procedure PROCESS_PREVIOUS_FIELD_COMMAND is ------------------------------------- begin -- -- if we are at beginning of line set field pointer to -- number of fields in line, otherwise decrement it. -- if WD.CURRENT_FIELD = 1 then WD.CURRENT_FIELD := LINE_FORMAT.NUMBER_OF_FIELDS; else WD.CURRENT_FIELD := WD.CURRENT_FIELD - 1; end if; -- -- determine new field type -- FIELD_TYPE := FIELD_NAME'VAL (LINE_FORMAT.COMPONENT (WD.CURRENT_FIELD).FIELD); -- -- put the field prompt to the screen and position cursor -- FIELD_PUT (WD.CURRENT_FIELD); -- end PROCESS_PREVIOUS_FIELD_COMMAND; -- ------------------------------------- procedure EXTRACT_FIELD is ------------------------------------- begin -- -- determine field positions -- START_END_AND_LENGTH (WD.CURRENT_FIELD); -- -- place current contents of field into field_gotten -- prior to calling get_field -- FIELD_GOTTEN (1..LENGTH_OF_FIELD) := WORKING_TEXT (START_OF_FIELD..END_OF_FIELD); -- end EXTRACT_FIELD; -- ------------------------------------- procedure REPLACE_FIELD is ------------------------------------- begin -- -- determine field positions -- START_END_AND_LENGTH (WD.CURRENT_FIELD); -- -- place new contents of field into working_text -- after calling get_field -- WORKING_TEXT (START_OF_FIELD..END_OF_FIELD) := FIELD_GOTTEN (1..LENGTH_OF_FIELD); -- end REPLACE_FIELD; -- ------------------------------------- procedure PROCESS_ERASE_FIELD_COMMAND is ------------------------------------- begin -- -- determine field positions -- START_END_AND_LENGTH (WD.CURRENT_FIELD); -- -- fill field_gotten with contents of prototype field -- FIELD_GOTTEN (1..LENGTH_OF_FIELD) := LINE_FORMAT.PROTOTYPE_LINE (START_OF_FIELD..END_OF_FIELD); -- -- fill working_text with contents of prototype field -- WORKING_TEXT (START_OF_FIELD..END_OF_FIELD) := FIELD_GOTTEN (1..LENGTH_OF_FIELD); -- -- now position cursor to beginning of the field in the work -- area, write over whatever is there, and reposition -- to the beginning of the field -- GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); PUT (FIELD_GOTTEN (1..LENGTH_OF_FIELD)); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); -- end PROCESS_ERASE_FIELD_COMMAND; -- ------------------------------------- procedure SAVE_LINE is ------------------------------------- begin -- -- pack the line of text and place it in the message -- PACK_LINE (WORKING_TEXT, LINE_FORMAT); WD.WORK_LINE.LINE_POINTER.TEXT_LINE := WORKING_TEXT; end SAVE_LINE; -- ---------------------------------------- begin -- finally starting process_edit_line_command -- WD.MODE := EDIT; -- -- we are about to begin editing the line whose data are given -- in work_line. set changes made flag, put the current -- contents of the line into working_text, set the field -- number to 1, set the field type to its proper value, and -- set next command to nil. -- WD.CHANGES_MADE_FLAG := TRUE; WORKING_TEXT (1..MAXIMUM_CHARACTERS_PER_LINE) := WD.WORK_LINE.LINE_POINTER.TEXT_LINE (1..MAXIMUM_CHARACTERS_PER_LINE); WD.CURRENT_FIELD := 1; FIELD_TYPE := FIELD_NAME'VAL (LINE_FORMAT.COMPONENT (WD.CURRENT_FIELD).FIELD); WD.NEXT_COMMAND := NIL; -- -- now we do the display work. first unpack the text, then -- position ourselves to the beginning of the work line area, -- display the text and the field prompt for the first field. -- UNPACK_LINE (WORKING_TEXT, LINE_FORMAT); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, 1); PUT (WORKING_TEXT (1..MAXIMUM_CHARACTERS_PER_LINE)); FIELD_PUT (1); -- -- now we loop until the user enters a command which causes us -- to cease editing this line -- loop -- -- now that we are into the edit field loop, we put the -- existing contents of the current field into field_gotten -- EXTRACT_FIELD; -- -- now we go input the field (ie. allow the user to edit it) -- GET_FIELD (FIELD_TYPE, FIELD_GOTTEN (1..LENGTH_OF_FIELD), LINE_FORMAT.COMPONENT (WD.CURRENT_FIELD).FIELD_POSITION, LINE_FORMAT.COMPONENT (WD.CURRENT_FIELD).FIELD_LENGTH, COMMAND_GOTTEN, COMMAND_FLAG); -- -- must now place the contents of field_gotten into the line -- REPLACE_FIELD; -- -- having handled the field gotten, we are now ready to -- handle any command which may also have been entered -- if COMMAND_FLAG = FALSE then PROCESS_NEXT_FIELD_COMMAND; else -- when command_flag = true; case COMMAND_GOTTEN is -- when NEXT_FIELD | RIGHT_ARROW => PROCESS_NEXT_FIELD_COMMAND; -- when PREV_FIELD | LEFT_ARROW => PROCESS_PREVIOUS_FIELD_COMMAND; -- when ERASE_FIELD => PROCESS_ERASE_FIELD_COMMAND; -- when CLASSIFY => PROCESS_CLASSIFY_MESSAGE_COMMAND; PROCESS_NEXT_FIELD_COMMAND; -- when PREV_LINE | UP_ARROW | NEXT_LINE | DOWN_ARROW | END_EDIT => --here we're leaving edit line so clean -- up. Set mode to scroll, validate the -- line. -- WD.MODE := SCROLL; LINE_VALIDATE; -- -- do we want to allow the user to -- enter a line which does not have -- all required fields. If not, enter -- required action here. -- WD.NEXT_COMMAND := COMMAND_GOTTEN; -- -- Now save the text of the line just -- edited and erase the work/amp areas -- to be rid of that line's text and -- prompts. Then redisplay the -- classification. -- SAVE_LINE; for K in TOP_OF_WORK_AREA..BOT_OF_WORK_AREA loop ERASE_LINE (K); end loop; if WD.ANY_AMP = TRUE then GOTO_CRT_POSITION (TOP_OF_AMP_AREA, 1); ERASE_TO_END_OF_SCREEN; DISPLAY_LOWER_CLASSIFICATION (WD.CURRENT_MESSAGE.CLASS); end if; exit; when others => PROMPT ("illegal command in this context"); PROCESS_NEXT_FIELD_COMMAND; end case; -- end if; -- end loop; -- end PROCESS_EDIT_LINE_COMMAND; -- --------------------------------------- procedure PROCESS_INSERT_LINE_COMMAND is --------------------------------------- NEW_LINE_NUMBER : POSITIVE; -- begin -- -- first check boundary condition -- if WD.CURRENT_MESSAGE.NUMBER_OF_LINES = MAXIMUM_LINES_PER_MESSAGE then PROMPT ("Already at maximum number of lines per message"); return; end if; -- -- this constitutes a change in the message -- WD.CHANGES_MADE_FLAG := TRUE; -- -- get new node, adjust pointers, and initialize -- INSERT_BEFORE (WD.CURRENT_MESSAGE, WD.WORK_LINE.LINE_POINTER); -- -- reset pointer to make the new line the working line -- WD.WORK_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER.PREV_LINE; -- -- if were at top line, make new line into top line -- if WD.WORK_LINE.LINE_NUMBER = WD.TOP_LINE.LINE_NUMBER then WD.TOP_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER; end if; -- -- increment line count -- WD.CURRENT_MESSAGE.NUMBER_OF_LINES := WD.CURRENT_MESSAGE.NUMBER_OF_LINES + 1; -- -- get type of line to be added -- GET_LINE_TYPE (TEMP_LINE_TYPE); WD.WORK_LINE.LINE_POINTER.LINE_TYPE := LINE_NAME'POS (TEMP_LINE_TYPE) + 1; LINE_TYPE_COUNTER := LINE_DEFINITION_IO.POSITIVE_COUNT (LINE_NAME'POS (TEMP_LINE_TYPE) + 1); -- LINE_DEFINITION_IO.READ (LINE_STRUCTURE_FILE, LINE_FORMAT, LINE_TYPE_COUNTER); -- --initialize the line's text with prototype line -- WD.WORK_LINE.LINE_POINTER.TEXT_LINE (1..MAXIMUM_CHARACTERS_PER_LINE) := LINE_FORMAT.PROTOTYPE_LINE (1..MAXIMUM_CHARACTERS_PER_LINE); -- -- now do display work. first, adjust bottom line display data. -- -- if the number of lines displayed is less than the number of -- crt lines available, then there is room at the bottom of the -- crt for another line, and the bottom line displayed will -- change in number, but it will be the same text. otherwise, -- the line number will remain the same, but the line pointer -- will change. -- if (WD.BOTTOM_LINE.LINE_NUMBER - WD.TOP_LINE.LINE_NUMBER + 1) < (BOT_OF_MESSAGE_AREA - TOP_OF_MESSAGE_AREA + 1) then WD.BOTTOM_LINE.LINE_NUMBER := WD.BOTTOM_LINE.LINE_NUMBER + 1; else WD.BOTTOM_LINE.LINE_POINTER := WD.BOTTOM_LINE.LINE_POINTER.PREV_LINE; end if; -- -- now re-display the message -- DISPLAY_MESSAGE; -- -- if this line is editable, set mode to edit and edit it; -- otherwise set mode to scroll and return. -- if LINE_FORMAT.NUMBER_OF_FIELDS > 0 then WD.MODE := EDIT; PROCESS_EDIT_LINE_COMMAND; else WD.MODE := SCROLL; end if; -- end PROCESS_INSERT_LINE_COMMAND; -- --------------------------------------- procedure PROCESS_DELETE_LINE_COMMAND is --------------------------------------- begin -- -- first check boundary conditions -- if WD.CURRENT_MESSAGE.NUMBER_OF_LINES = 1 then PROMPT (" can't delete the only line in a message"); return; end if; -- -- -- this constitutes a change in the message -- WD.CHANGES_MADE_FLAG := TRUE; -- -- decrement the number of lines in the message -- WD.CURRENT_MESSAGE.NUMBER_OF_LINES := WD.CURRENT_MESSAGE.NUMBER_OF_LINES - 1; -- -- we take this in three cases : deleting the first line, -- the last line, or some middle line of the message. -- if WD.WORK_LINE.LINE_NUMBER = 1 then -- -- here we are deleting 1st line of the message -- reset pointer to 2nd and delete 1st -- WD.WORK_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER.NEXT_LINE; LINE_TYPE_COUNTER := LINE_DEFINITION_IO.POSITIVE_COUNT (WD.WORK_LINE.LINE_POINTER.LINE_TYPE); -- LINE_DEFINITION_IO.READ (LINE_STRUCTURE_FILE, LINE_FORMAT, LINE_TYPE_COUNTER); DELETE (WD.CURRENT_MESSAGE, WD.WORK_LINE.LINE_POINTER.PREV_LINE); -- -- now we scroll the message area up, display any new -- bottom line if there is one, and display the new 1st -- line backlit. While we are doing that we also update -- the display pointers. -- SCROLL_SCREEN (TOP_OF_MESSAGE_AREA + 1, BOT_OF_MESSAGE_AREA, UP); WD.TOP_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER; -- -- Is there to be a new line displayed at the bottom ? -- if WD.CURRENT_MESSAGE.NUMBER_OF_LINES < (BOT_OF_MESSAGE_AREA - TOP_OF_MESSAGE_AREA + 1) then -- -- here there is a not a new line to be displayed. -- change number of bottom line, and backlight new -- working line -- WD.BOTTOM_LINE.LINE_NUMBER := WD.BOTTOM_LINE.LINE_NUMBER - 1; DISPLAY_LINE (WD.WORK_LINE, TRUE); -- else -- -- here there is a new line to be displayed. change pointer -- to bottom line, display new bottom line , and backlight -- new working line. -- WD.BOTTOM_LINE.LINE_POINTER := WD.BOTTOM_LINE.LINE_POINTER.NEXT_LINE; DISPLAY_LINE (WD.BOTTOM_LINE, FALSE); DISPLAY_LINE (WD.WORK_LINE, TRUE); end if; -- elsif WD.WORK_LINE.LINE_NUMBER > WD.CURRENT_MESSAGE.NUMBER_OF_LINES then -- -- here we are deleting the last line of the message. -- reset pointer, set current line, delete old working line -- WD.WORK_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER.PREV_LINE; WD.WORK_LINE.LINE_NUMBER := WD.WORK_LINE.LINE_NUMBER - 1; LINE_TYPE_COUNTER := LINE_DEFINITION_IO.POSITIVE_COUNT (WD.WORK_LINE.LINE_POINTER.LINE_TYPE); -- LINE_DEFINITION_IO.READ (LINE_STRUCTURE_FILE, LINE_FORMAT, LINE_TYPE_COUNTER); DELETE (WD.CURRENT_MESSAGE, WD.WORK_LINE.LINE_POINTER.NEXT_LINE); -- -- If the whole message is on the screen, we do one thing -- otherwise we take another approach -- if WD.TOP_LINE.LINE_NUMBER = 1 then -- -- here we erase the old bottom line, backlite then new -- and reset pointers -- GOTO_CRT_POSITION (WD.BOTTOM_LINE.LINE_NUMBER + TOP_OF_MESSAGE_AREA - 1, 1); ERASE_LINE; WD.BOTTOM_LINE.LINE_NUMBER := WD.BOTTOM_LINE.LINE_NUMBER - 1; WD.BOTTOM_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER; DISPLAY_LINE (WD.WORK_LINE, TRUE); else -- -- here we scroll down, rewrite the new top and bottom -- lines, and adjust pointers -- SCROLL_SCREEN (TOP_OF_MESSAGE_AREA, BOT_OF_MESSAGE_AREA, DOWN); WD.TOP_LINE.LINE_NUMBER := WD.TOP_LINE.LINE_NUMBER - 1; WD.TOP_LINE.LINE_POINTER := WD.TOP_LINE.LINE_POINTER.PREV_LINE; WD.BOTTOM_LINE.LINE_NUMBER := WD.BOTTOM_LINE.LINE_NUMBER - 1; WD.BOTTOM_LINE.LINE_POINTER := WD.BOTTOM_LINE.LINE_POINTER.PREV_LINE; DISPLAY_LINE (WD.TOP_LINE, FALSE); DISPLAY_LINE (WD.BOTTOM_LINE, TRUE); end if; else -- -- here we are deleting a middle line of the message. -- reset pointers, set current line, delete old working line -- -- we take this in the following cases : -- 1. bottom line of the message is not on the screen -- 2. bottom line is on the screen, but the top line is not -- 3. entire message is on the screen -- if WD.BOTTOM_LINE.LINE_NUMBER <= WD.CURRENT_MESSAGE.NUMBER_OF_LINES then -- -- here we shall scroll from the bottom of the screen -- up, write the new bottom line on the screen unbacklit, -- write the new working line backlit, and adjust pointers -- WD.WORK_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER.NEXT_LINE; LINE_TYPE_COUNTER := LINE_DEFINITION_IO.POSITIVE_COUNT (WD.WORK_LINE.LINE_POINTER.LINE_TYPE); -- LINE_DEFINITION_IO.READ (LINE_STRUCTURE_FILE, LINE_FORMAT, LINE_TYPE_COUNTER); DELETE (WD.CURRENT_MESSAGE, WD.WORK_LINE.LINE_POINTER.PREV_LINE); -- if WD.BOTTOM_LINE.LINE_NUMBER = WD.WORK_LINE.LINE_NUMBER then -- -- here we're deleting the bottom line displayed -- GOTO_CRT_POSITION (BOT_OF_MESSAGE_AREA, 1); ERASE_LINE; WD.BOTTOM_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER; DISPLAY_LINE (WD.WORK_LINE, TRUE); -- else -- -- here we're deleting a line above the bottom line -- SCROLL_SCREEN (WD.WORK_LINE.LINE_NUMBER - WD.TOP_LINE.LINE_NUMBER + TOP_OF_MESSAGE_AREA, BOT_OF_MESSAGE_AREA, UP); WD.BOTTOM_LINE.LINE_POINTER := WD.BOTTOM_LINE.LINE_POINTER.NEXT_LINE; DISPLAY_LINE (WD.BOTTOM_LINE, FALSE); DISPLAY_LINE (WD.WORK_LINE, TRUE); -- -- did we delete the top line displayed ? -- if WD.TOP_LINE.LINE_NUMBER = WD.WORK_LINE.LINE_NUMBER then WD.TOP_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER; end if; end if; -- elsif WD.TOP_LINE.LINE_NUMBER > 1 then -- -- here we shall scroll from the top of the screen down, -- write the new top line on the screen unbacklit, -- write the new working line backlit, and adjust pointers -- WD.WORK_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER.PREV_LINE; LINE_TYPE_COUNTER := LINE_DEFINITION_IO.POSITIVE_COUNT (WD.WORK_LINE.LINE_POINTER.LINE_TYPE); -- LINE_DEFINITION_IO.READ (LINE_STRUCTURE_FILE, LINE_FORMAT, LINE_TYPE_COUNTER); WD.WORK_LINE.LINE_NUMBER := WD.WORK_LINE.LINE_NUMBER - 1; WD.BOTTOM_LINE.LINE_NUMBER := WD.BOTTOM_LINE.LINE_NUMBER - 1; WD.TOP_LINE.LINE_NUMBER := WD.TOP_LINE.LINE_NUMBER - 1; WD.TOP_LINE.LINE_POINTER := WD.TOP_LINE.LINE_POINTER.PREV_LINE; DELETE (WD.CURRENT_MESSAGE, WD.WORK_LINE.LINE_POINTER.NEXT_LINE); -- if WD.WORK_LINE.LINE_NUMBER = WD.TOP_LINE.LINE_NUMBER then -- -- here we are deleting the top line -- GOTO_CRT_POSITION (TOP_OF_MESSAGE_AREA, 1); ERASE_LINE; DISPLAY_LINE (WD.WORK_LINE, TRUE); -- else -- -- here we are deleting some interior line -- SCROLL_SCREEN (TOP_OF_MESSAGE_AREA, WD.WORK_LINE.LINE_NUMBER - WD.TOP_LINE.LINE_NUMBER + TOP_OF_MESSAGE_AREA, DOWN); DISPLAY_LINE (WD.TOP_LINE, FALSE); DISPLAY_LINE (WD.WORK_LINE, TRUE); end if; else -- -- here the whole message is on the screen, so we scroll up -- rewriting the new working line backlit, and adjust -- pointers. -- WD.WORK_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER.NEXT_LINE; LINE_TYPE_COUNTER := LINE_DEFINITION_IO.POSITIVE_COUNT (WD.WORK_LINE.LINE_POINTER.LINE_TYPE); -- LINE_DEFINITION_IO.READ (LINE_STRUCTURE_FILE, LINE_FORMAT, LINE_TYPE_COUNTER); DELETE (WD.CURRENT_MESSAGE, WD.WORK_LINE.LINE_POINTER.PREV_LINE); WD.BOTTOM_LINE.LINE_NUMBER := WD.BOTTOM_LINE.LINE_NUMBER - 1; SCROLL_SCREEN (TOP_OF_MESSAGE_AREA + WD.WORK_LINE.LINE_NUMBER - 1, BOT_OF_MESSAGE_AREA, UP); DISPLAY_LINE (WD.WORK_LINE, TRUE); end if; end if; end PROCESS_DELETE_LINE_COMMAND; -- --------------------------------------- procedure PROCESS_NEXT_LINE_COMMAND is --------------------------------------- -- begin -- -- check boundary condition -- if (WD.WORK_LINE.LINE_NUMBER = WD.CURRENT_MESSAGE.NUMBER_OF_LINES) and (WD.CURRENT_MESSAGE.NUMBER_OF_LINES = MAXIMUM_LINES_PER_MESSAGE) then PROMPT ("Already at maximum number of lines per message"); return; end if; -- -- if the user is on the last line and activates this command, -- we insert a new line at the end of the message. if not at -- the last line, we simply move on to the next line. -- if WD.WORK_LINE.LINE_NUMBER < WD.CURRENT_MESSAGE.NUMBER_OF_LINES then -- -- here we do not add a line, we simply move on to the next -- line. to do that, first we un-backlight the old working -- line, and update the data on the new working line -- DISPLAY_LINE (WD.WORK_LINE, FALSE); WD.WORK_LINE.LINE_NUMBER := WD.WORK_LINE.LINE_NUMBER + 1; WD.WORK_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER.NEXT_LINE; LINE_TYPE_COUNTER := LINE_DEFINITION_IO.POSITIVE_COUNT (WD.WORK_LINE.LINE_POINTER.LINE_TYPE); -- LINE_DEFINITION_IO.READ (LINE_STRUCTURE_FILE, LINE_FORMAT, LINE_TYPE_COUNTER); -- -- if the new working line is not on the screen (we were at -- the bottom) scroll the message area up, and adjust the -- top/bottom line displayed data -- if WD.WORK_LINE.LINE_NUMBER > WD.BOTTOM_LINE.LINE_NUMBER then SCROLL_SCREEN (TOP_OF_MESSAGE_AREA, BOT_OF_MESSAGE_AREA, UP); WD.TOP_LINE.LINE_NUMBER := WD.TOP_LINE.LINE_NUMBER + 1; WD.TOP_LINE.LINE_POINTER := WD.TOP_LINE.LINE_POINTER.NEXT_LINE; WD.BOTTOM_LINE.LINE_NUMBER := WD.BOTTOM_LINE.LINE_NUMBER + 1; WD.BOTTOM_LINE.LINE_POINTER := WD.BOTTOM_LINE.LINE_POINTER.NEXT_LINE; end if; -- -- backlight the new working line -- DISPLAY_LINE (WD.WORK_LINE, TRUE); -- else -- -- here we were at the end of the message so we must add a -- new line at the bottom of the message -- -- get new node, adjust pointers, and initialize -- INSERT_AFTER (WD.CURRENT_MESSAGE, WD.WORK_LINE.LINE_POINTER); -- -- reset pointer to make the new line the working line and -- increment line count -- WD.WORK_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER.NEXT_LINE; WD.CURRENT_MESSAGE.TAIL := WD.WORK_LINE.LINE_POINTER; WD.CURRENT_MESSAGE.NUMBER_OF_LINES := WD.CURRENT_MESSAGE.NUMBER_OF_LINES + 1; WD.WORK_LINE.LINE_NUMBER := WD.CURRENT_MESSAGE.NUMBER_OF_LINES; -- -- get type of line to be added and -- initialize the line's text with prototype line -- GET_LINE_TYPE (TEMP_LINE_TYPE); WD.WORK_LINE.LINE_POINTER.LINE_TYPE := LINE_NAME'POS (TEMP_LINE_TYPE) + 1; LINE_TYPE_COUNTER := LINE_DEFINITION_IO.POSITIVE_COUNT (LINE_NAME'POS (TEMP_LINE_TYPE) + 1); LINE_DEFINITION_IO.READ (LINE_STRUCTURE_FILE, LINE_FORMAT, LINE_TYPE_COUNTER); WD.WORK_LINE.LINE_POINTER.TEXT_LINE (1..MAXIMUM_CHARACTERS_PER_LINE) := LINE_FORMAT.PROTOTYPE_LINE (1..MAXIMUM_CHARACTERS_PER_LINE); -- -- this constitutes a change -- WD.CHANGES_MADE_FLAG := TRUE; -- -- now do the display work. first update bottom ln dsp data -- WD.BOTTOM_LINE.LINE_NUMBER := WD.BOTTOM_LINE.LINE_NUMBER + 1; WD.BOTTOM_LINE.LINE_POINTER := WD.BOTTOM_LINE.LINE_POINTER.NEXT_LINE; -- -- if we were at the bottom of the screen, then we will have -- a new top line displayed, so update that data -- if (WD.BOTTOM_LINE.LINE_NUMBER - WD.TOP_LINE.LINE_NUMBER) > (BOT_OF_MESSAGE_AREA - TOP_OF_MESSAGE_AREA) then WD.TOP_LINE.LINE_POINTER := WD.TOP_LINE.LINE_POINTER.NEXT_LINE; WD.TOP_LINE.LINE_NUMBER := WD.TOP_LINE.LINE_NUMBER + 1; end if; -- -- now re-display the message -- DISPLAY_MESSAGE; -- -- if this line is editable, set mode to edit and edit it; -- otherwise set mode to scroll and return. -- if LINE_FORMAT.NUMBER_OF_FIELDS > 0 then WD.MODE := EDIT; PROCESS_EDIT_LINE_COMMAND; else WD.MODE := SCROLL; end if; -- end if; end PROCESS_NEXT_LINE_COMMAND; -- -------------------------------------- procedure PROCESS_PREV_LINE_COMMAND is -------------------------------------- begin -- -- check boundary condition -- if WD.WORK_LINE.LINE_POINTER = WD.CURRENT_MESSAGE.HEAD then PROMPT ("can't back-up past top of message"); return; end if; -- -- first we un-backlight the old working line, and update the -- data for the new working line -- DISPLAY_LINE (WD.WORK_LINE, FALSE); WD.WORK_LINE.LINE_NUMBER := WD.WORK_LINE.LINE_NUMBER - 1; WD.WORK_LINE.LINE_POINTER := WD.WORK_LINE.LINE_POINTER.PREV_LINE; LINE_TYPE_COUNTER := LINE_DEFINITION_IO.POSITIVE_COUNT (WD.WORK_LINE.LINE_POINTER.LINE_TYPE); -- LINE_DEFINITION_IO.READ (LINE_STRUCTURE_FILE, LINE_FORMAT, LINE_TYPE_COUNTER); -- -- if the new working line is not on the screen (we were at -- the bottom) scroll the message area down, and adjust the -- top/bottom line displayed data -- if WD.WORK_LINE.LINE_NUMBER < WD.TOP_LINE.LINE_NUMBER then SCROLL_SCREEN (TOP_OF_MESSAGE_AREA, BOT_OF_MESSAGE_AREA, DOWN); WD.TOP_LINE.LINE_NUMBER := WD.TOP_LINE.LINE_NUMBER - 1; WD.TOP_LINE.LINE_POINTER := WD.TOP_LINE.LINE_POINTER.PREV_LINE; WD.BOTTOM_LINE.LINE_NUMBER := WD.BOTTOM_LINE.LINE_NUMBER - 1; WD.BOTTOM_LINE.LINE_POINTER := WD.BOTTOM_LINE.LINE_POINTER.PREV_LINE; end if; -- -- backlight the new working line -- DISPLAY_LINE (WD.WORK_LINE, TRUE); -- end PROCESS_PREV_LINE_COMMAND; -- ------------------------------------------------------------------------ use LINE_DEFINITION_IO; use FIELD_PROMPT_IO; use PROMPT_VECTOR_IO; -- -- finally we get to the body of the main procedure -- begin -- -- to start, we must go get the message we are to edit, and perform -- some initialization. -- INITIALIZE_TERMINAL; -- OPEN (LINE_STRUCTURE_FILE, IN_FILE, LINE_STRUCTURE_FILE_NAME); -- OPEN (FIELD_PROMPT_FILE, IN_FILE, FIELD_PROMPT_FILE_NAME); -- OPEN (PROMPT_VECTOR_FILE, IN_FILE, PROMPT_VECTOR_FILE_NAME); -- -- WD.CURRENT_MESSAGE := MESSAGE_PASSED; -- FILL_LINE_TYPES; -- determine the type of each line and place in -- in the line_type field of its message component -- read the line structure data for the first line -- into line_format -- -- we initialize the working, top and bottom lines displayed data -- WD.WORK_LINE.LINE_NUMBER := 1; WD.WORK_LINE.LINE_POINTER := WD.CURRENT_MESSAGE.HEAD; -- EDITOR_TYPES.CURRENT_LINE := - 1; --ensures won't match the first time LINE_TYPE_COUNTER := LINE_DEFINITION_IO.POSITIVE_COUNT (WD.WORK_LINE.LINE_POINTER.LINE_TYPE); LINE_DEFINITION_IO.READ (LINE_STRUCTURE_FILE, LINE_FORMAT, LINE_TYPE_COUNTER); -- WD.TOP_LINE.LINE_NUMBER := 1; WD.TOP_LINE.LINE_POINTER := WD.CURRENT_MESSAGE.HEAD; -- -- if screen is filled, then bottom line has line # = # lines in crt -- message area, otherwise bottom line has # = number of lines in -- message -- if WD.CURRENT_MESSAGE.NUMBER_OF_LINES >= (BOT_OF_MESSAGE_AREA - TOP_OF_MESSAGE_AREA + 1) then WD.BOTTOM_LINE.LINE_NUMBER := BOT_OF_MESSAGE_AREA - TOP_OF_MESSAGE_AREA + 1; else WD.BOTTOM_LINE.LINE_NUMBER := WD.CURRENT_MESSAGE.NUMBER_OF_LINES; end if; -- -- we get the pointer to the bottom line displayed the hard way (BFM) -- WD.BOTTOM_LINE.LINE_POINTER := WD.CURRENT_MESSAGE.HEAD; -- for I in 1..(WD.CURRENT_MESSAGE.NUMBER_OF_LINES - 1) loop -- WD.BOTTOM_LINE.LINE_POINTER := WD.BOTTOM_LINE.LINE_POINTER.NEXT_LINE; -- end loop; -- -- now we display the menu, the message classification, and -- the message itself. -- DISPLAY_MENU ("editmenu"); -- DISPLAY_CLASSIFICATION (WD.CURRENT_MESSAGE.CLASS); -- DISPLAY_MESSAGE; -- -- we initialize to scroll mode and no changes made. we set the -- WD.MODE := SCROLL; WD.CHANGES_MADE_FLAG := FALSE; -- -- now we enter the scroll mode loop. -- MAIN : loop WD.NEXT_COMMAND := NIL; READ_NOECHO (CHAR); -- if CHAR (1) = START_OF_FUNCTION_KEY then GET_COMMAND (USER_INPUT); -- gets user's command -- elsif CHAR (1) = ASCII.CR then USER_INPUT := NEXT_LINE; -- -- handle arrows, etc here -- else USER_INPUT := NIL; -- end if; -- declare EMBEDDED_COMMAND : exception; begin case USER_INPUT is -- when CLASSIFY => PROCESS_CLASSIFY_MESSAGE_COMMAND; TEMP_INTEGER := WD.WORK_LINE.LINE_NUMBER - WD.TOP_LINE.LINE_NUMBER + TOP_OF_MESSAGE_AREA; GOTO_CRT_POSITION (TEMP_INTEGER, 1); -- when PREV_LINE | UP_ARROW => PROCESS_PREV_LINE_COMMAND; -- when NEXT_LINE | DOWN_ARROW => PROCESS_NEXT_LINE_COMMAND; if WD.NEXT_COMMAND /= NIL then raise EMBEDDED_COMMAND; end if; -- -- when INSERT_LINE => PROCESS_INSERT_LINE_COMMAND; if WD.NEXT_COMMAND /= NIL then raise EMBEDDED_COMMAND; end if; -- -- when DELETE_LINE => PROCESS_DELETE_LINE_COMMAND; -- when EDIT_LINE | RIGHT_ARROW => if LINE_FORMAT.NUMBER_OF_FIELDS > 0 then -- -- IMPORTANT - line editing is embedded -- in process_edit_line_command. -- PROCESS_EDIT_LINE_COMMAND; -- If we came back with a command, we must handle it here -- before we continue with the main loop. -- case WD.NEXT_COMMAND is when PREV_LINE | UP_ARROW => PROCESS_PREV_LINE_COMMAND; -- when NEXT_LINE | DOWN_ARROW => if WD.NEXT_COMMAND /= NIL then raise EMBEDDED_COMMAND; end if; -- when END_EDIT => exit MAIN; -- when others => PROMPT ("others in main"); end case; else PROMPT ("Can't edit a line with no fields"); end if; -- when PREV_FIELD | NEXT_FIELD | ERASE_FIELD => PROMPT ("this command not available in scroll mode"); -- when END_EDIT => exit MAIN; -- when others => PROMPT ("illegal input, please enter command"); -- end case; exception when embedded_command => -- -- If we came back with a command, we must handle it here -- before we continue with the main loop. -- case WD.NEXT_COMMAND is when PREV_LINE | UP_ARROW => PROCESS_PREV_LINE_COMMAND; -- when NEXT_LINE | DOWN_ARROW => PROCESS_NEXT_LINE_COMMAND; -- when END_EDIT => exit MAIN; -- when others => PROMPT ("others in main"); end case; end; end loop MAIN; CLOSE (LINE_STRUCTURE_FILE); CLOSE (FIELD_PROMPT_FILE); CLOSE (PROMPT_VECTOR_FILE); MESSAGE_PASSED := WD.CURRENT_MESSAGE; VALIDATE_LINE_INSERTION; end EDITOR; -- end FILED_GENERIC_MESSAGE_EDITOR; end FILE_GENERIC; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --genmenu.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE GENERAL_MENU_ROUTINES -- -- File name : GENMENU.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with FILE_ACCESS; use FILE_ACCESS; with LINKED_LIST_PROCEDURES; use LINKED_LIST_PROCEDURES; -- -- package GENERAL_MENU_ROUTINES is -- -- type MENU_NAMES is (GMHF, GMHF_1, GMHF_11, GMHF_12, GMHF_2, GMHF_3, GMHF_31, NONE ); -- type TYPES_OF_FIELDS is (COMMAND_FIELD, DATA_FIELD, LIST_FIELD ); -- type MENU_FIELD is record FIELD_TYPE : TYPES_OF_FIELDS; NUMBER_OF_ASSOCIATES : NATURAL; POSITION : CRT_POSITION; end record; -- type FIELD_ARRAY is array (INTEGER range <>) of MENU_FIELD; -- LENGTH_OF_DATA_FIELD : constant INTEGER := 4; type STRING_VALUE is array (INTEGER range <>) of STRING (1..LENGTH_OF_DATA_FIELD); -- DIRECTORY_LINE_NUMBER : POSITIVE := 6; CURRENT_TYPE : DIRECTORY_ENTRY; -- MESSAGE_TYPE_COLUMN : constant CRT_COLS := 60; NUMBER_OF_MESSAGES : constant CRT_COLS := 72; TYPE_AND_NUMBER_STRING : STRING (1..16); -- TOP_LINE : NODE; BOTTOM_LINE : NODE; START_OF_MSG : NODE; END_OF_MSG : NODE; --------------------------- procedure LOAD_MESSAGE_TYPE (FIELDS : in FIELD_ARRAY; NUMBER_OF_FIELDS : in INTEGER; CURRENT_FIELD : in POSITIVE; MESSAGE_STRING : in STRING); --------------------------- ----------------------------- procedure GENERAL_MENU_DRIVER (CURRENT_FIELD : in out POSITIVE; NUMBER_OF_FIELDS : in INTEGER; FIELDS : in FIELD_ARRAY; CURRENT_MENU : in MENU_NAMES; CURRENT_ENTRY : in out DIRECTORY_ENTRY; VALUE : in out STRING_VALUE); ----------------------------- -- end GENERAL_MENU_ROUTINES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --genmenu.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE GENERAL_MENU_ROUTINES -- -- File name : GENMENU.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; -- package body GENERAL_MENU_ROUTINES is -- -- --------------------------- procedure LOAD_MESSAGE_TYPE (FIELDS : in FIELD_ARRAY; NUMBER_OF_FIELDS : in INTEGER; CURRENT_FIELD : in POSITIVE; MESSAGE_STRING : in STRING) is --------------------------- begin -- UNDERSCORE_ON; for I in 1..NUMBER_OF_FIELDS loop if FIELDS (I).FIELD_TYPE = LIST_FIELD then GOTO_CRT_POSITION (FIELDS (I).POSITION); PUT (MESSAGE_STRING); end if; end loop; -- GOTO_CRT_POSITION (FIELDS (CURRENT_FIELD).POSITION); UNDERSCORE_OFF; -- end LOAD_MESSAGE_TYPE; -- ----------------------------- procedure GENERAL_MENU_DRIVER (CURRENT_FIELD : in out POSITIVE; NUMBER_OF_FIELDS : in INTEGER; FIELDS : in FIELD_ARRAY; CURRENT_MENU : in MENU_NAMES; CURRENT_ENTRY : in out DIRECTORY_ENTRY; VALUE : in out STRING_VALUE) is ----------------------------- -- CURRENT_POSITION : INTEGER; ONE_CHARACTER : STRING (1..1); THE_FUNCTION_KEY : FUNCTION_KEY; SYSTEM_DRIVER_KEY : SYSTEM_DRIVER_KEYS; -- -- some internal routines to follow -- ----------------- procedure TAB (CURRENT_FIELD : in out POSITIVE; NUMBER_OF_FIELDS : in INTEGER; FIELDS : in FIELD_ARRAY) is ----------------- -- -- the key hit is the tab key -- begin if CURRENT_FIELD = NUMBER_OF_FIELDS then CURRENT_FIELD := 1; else CURRENT_FIELD := CURRENT_FIELD + 1; end if; GOTO_CRT_POSITION (FIELDS (CURRENT_FIELD).POSITION); -- -- end TAB; -- -- ------------------ procedure BACK_TAB (CURRENT_FIELD : in out POSITIVE; NUMBER_OF_FIELDS : in INTEGER; FIELDS : in FIELD_ARRAY) is ------------------ -- -- the key hit is the back tab key -- begin if CURRENT_FIELD = 1 then CURRENT_FIELD := NUMBER_OF_FIELDS; else CURRENT_FIELD := CURRENT_FIELD - 1; end if; GOTO_CRT_POSITION (FIELDS (CURRENT_FIELD).POSITION); -- -- end BACK_TAB; -- -- -------------------------- procedure SCROLL_DIRECTORY (DIRECTION : in UP_OR_DOWN; ELEMENT : in out DIRECTORY_ENTRY) is -------------------------- -- THIS_ENTRY : DIRECTORY_ENTRY; -- procedure SCROLL_UP (CURRENT_ENTRY : in DIRECTORY_ENTRY) is -- begin -- THIS_ENTRY := CURRENT_ENTRY; for I in reverse 6..20 loop GOTO_CRT_POSITION (CRT_ROWS (I), MESSAGE_TYPE_COLUMN); TYPE_AND_NUMBER_STRING := THIS_ENTRY.TYPE_STRING & THIS_ENTRY.NUMBER_STRING; PUT (TYPE_AND_NUMBER_STRING); THIS_ENTRY := THIS_ENTRY.PREVIOUS_MESSAGE_TYPE; end loop; -- end SCROLL_UP; -- -- procedure SCROLL_DOWN (CURRENT_ENTRY : in DIRECTORY_ENTRY) is -- begin -- THIS_ENTRY := CURRENT_ENTRY; for I in 6..20 loop GOTO_CRT_POSITION (CRT_ROWS (I), MESSAGE_TYPE_COLUMN); TYPE_AND_NUMBER_STRING := THIS_ENTRY.TYPE_STRING & THIS_ENTRY.NUMBER_STRING; PUT (TYPE_AND_NUMBER_STRING); THIS_ENTRY := THIS_ENTRY.NEXT_MESSAGE_TYPE; end loop; -- end SCROLL_DOWN; -- -- begin -- -- do the boundary checks first -- if (DIRECTION = DOWN and ELEMENT.PREVIOUS_MESSAGE_TYPE = null) or (DIRECTION = UP and ELEMENT.NEXT_MESSAGE_TYPE = null) then -- RING_BELL; -- else -- -- first un-highlight the current entry -- GOTO_CRT_POSITION (DIRECTORY_LINE_NUMBER, MESSAGE_TYPE_COLUMN); TYPE_AND_NUMBER_STRING := ELEMENT.TYPE_STRING & ELEMENT.NUMBER_STRING; PUT (TYPE_AND_NUMBER_STRING); -- -- now adjust pointer based on direction -- if DIRECTION = DOWN then ELEMENT := ELEMENT.PREVIOUS_MESSAGE_TYPE; DIRECTORY_LINE_NUMBER := DIRECTORY_LINE_NUMBER - 1; -- else -- up -- ELEMENT := ELEMENT.NEXT_MESSAGE_TYPE; DIRECTORY_LINE_NUMBER := DIRECTORY_LINE_NUMBER + 1; -- end if; -- -- check for scrolling -- if DIRECTORY_LINE_NUMBER > 20 then SCROLL_UP (ELEMENT); DIRECTORY_LINE_NUMBER := 20; elsif DIRECTORY_LINE_NUMBER < 6 then SCROLL_DOWN (ELEMENT); DIRECTORY_LINE_NUMBER := 6; end if; -- -- highlight the new entry -- GOTO_CRT_POSITION (DIRECTORY_LINE_NUMBER, MESSAGE_TYPE_COLUMN); REVERSE_VIDEO_ON; TYPE_AND_NUMBER_STRING := ELEMENT.TYPE_STRING & ELEMENT.NUMBER_STRING; PUT (TYPE_AND_NUMBER_STRING); REVERSE_VIDEO_OFF; -- -- return cursor to current field -- GOTO_CRT_POSITION (FIELDS (CURRENT_FIELD).POSITION); -- end if; -- end SCROLL_DIRECTORY; -- -- ------------------------ procedure SCROLL_MESSAGE (DIRECTION : UP_OR_DOWN) is ------------------------ procedure SCROLL_UP is begin if BOTTOM_LINE = END_OF_MSG then PROMPT ("Bottom of message reached"); else SAVE_CURSOR_POSITION; UNDERSCORE_OFF; SCROLL_SCREEN (5, 18, UP); BOTTOM_LINE := BOTTOM_LINE.NEXT_LINE; TOP_LINE := TOP_LINE.NEXT_LINE; GOTO_CRT_POSITION (18, 1); PUT (BOTTOM_LINE.TEXT_LINE); RESTORE_CURSOR_POSITION; end if; end SCROLL_UP; ------------- ------------- procedure SCROLL_DOWN is begin if TOP_LINE = START_OF_MSG then PROMPT ("Top of message reached"); else SAVE_CURSOR_POSITION; UNDERSCORE_OFF; SCROLL_SCREEN (5, 18, DOWN); BOTTOM_LINE := BOTTOM_LINE.PREV_LINE; TOP_LINE := TOP_LINE.PREV_LINE; GOTO_CRT_POSITION (5, 1); PUT (TOP_LINE.TEXT_LINE); RESTORE_CURSOR_POSITION; end if; end SCROLL_DOWN; -- -- driver to call proper scrolling routine -- begin case DIRECTION is when UP => SCROLL_UP; when DOWN => SCROLL_DOWN; end case; end SCROLL_MESSAGE; -- -- -- here starts the main part of the rouitne -- begin -- GOTO_CRT_POSITION (FIELDS (CURRENT_FIELD).POSITION); -- loop -- -- read one character and if its an escape then -- read two more because its probably a function key -- if its not an escape then its a normal character -- probably so process it if its legal for the current field -- -- get one character -- READ_NOECHO (ONE_CHARACTER); -- if ONE_CHARACTER (1) = ASCII.ESC then -- -- get two more characters to determine the function key -- READ_NOECHO (THE_FUNCTION_KEY); -- if THE_FUNCTION_KEY = SYSTEM_DRIVER_KEY.TAB then -- -- the key hit is the tab key -- TAB (CURRENT_FIELD, NUMBER_OF_FIELDS, FIELDS (1..NUMBER_OF_FIELDS)); CURRENT_POSITION := 1; -- elsif THE_FUNCTION_KEY = SYSTEM_DRIVER_KEY.BACK_TAB then -- -- the key hit is the back tab key -- BACK_TAB (CURRENT_FIELD, NUMBER_OF_FIELDS, FIELDS (1..NUMBER_OF_FIELDS)); CURRENT_POSITION := 1; -- elsif THE_FUNCTION_KEY = SYSTEM_DRIVER_KEY.ARROW_UP then -- -- the key hit is arrow_up -- if CURRENT_MENU = GMHF_31 then SCROLL_MESSAGE (DOWN); else -- -- all other menus have a directory displayed which -- may be scrolled. -- if FIELDS (CURRENT_FIELD).FIELD_TYPE = LIST_FIELD then -- SCROLL_DIRECTORY (DOWN, CURRENT_ENTRY); LOAD_MESSAGE_TYPE (FIELDS, NUMBER_OF_FIELDS, CURRENT_FIELD, CURRENT_ENTRY.TYPE_STRING); else -- -- not a legal key at this field -- RING_BELL; -- end if; -- end if; -- elsif THE_FUNCTION_KEY = SYSTEM_DRIVER_KEY.ARROW_DOWN then -- -- the key hit is arrow_down -- if CURRENT_MENU = GMHF_31 then SCROLL_MESSAGE (UP); else -- -- all other menus have a directory displayed which -- may be scrolled. -- if FIELDS (CURRENT_FIELD).FIELD_TYPE = LIST_FIELD then -- SCROLL_DIRECTORY (UP, CURRENT_ENTRY); LOAD_MESSAGE_TYPE (FIELDS, NUMBER_OF_FIELDS, CURRENT_FIELD, CURRENT_ENTRY.TYPE_STRING); else -- -- not a legal key at this field -- RING_BELL; end if; -- end if; -- elsif THE_FUNCTION_KEY = SYSTEM_DRIVER_KEY.COMMAND then -- -- the key hit is the command key -- so evaluate it -- if FIELDS (CURRENT_FIELD).FIELD_TYPE = COMMAND_FIELD then exit; else RING_BELL; -- not legal on non command type field end if; -- else -- -- if none of the above it was an illegal entry -- RING_BELL; end if; -- else -- -- process of elimination leaves us with just a single -- character being received from the key board so if its -- legal then process it -- if FIELDS (CURRENT_FIELD).FIELD_TYPE = DATA_FIELD then if ONE_CHARACTER (1) = ' ' or (ONE_CHARACTER (1) >= '0' and ONE_CHARACTER (1) <= '9') then -- VALUE (CURRENT_FIELD) (CURRENT_POSITION) := ONE_CHARACTER (1); UNDERSCORE_ON; PUT (ONE_CHARACTER (1)); -- echos the char to the screen UNDERSCORE_OFF; -- if CURRENT_POSITION >= LENGTH_OF_DATA_FIELD then -- -- field is full to its max so move to next field -- TAB (CURRENT_FIELD, NUMBER_OF_FIELDS, FIELDS (1..NUMBER_OF_FIELDS)); CURRENT_POSITION := 1; else -- -- just increment the current position on the field -- CURRENT_POSITION := CURRENT_POSITION + 1; end if; -- else -- illegal entry for numeric data field RING_BELL; end if; -- else -- cant type a character on a non data field RING_BELL; end if; -- end if; -- -- end loop; -- -- end GENERAL_MENU_DRIVER; -- end GENERAL_MENU_ROUTINES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --calledit.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE CALL_EDITOR -- -- File name : CALLEDIT.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with file_access; use file_access; with linked_list_procedures; use linked_list_procedures; -- package call_editor is -- -- only one procedure within this package -- procedure call_the_editor(message_pointer : in out message; directory_info : in out directory_entry; message_number : in out natural); -- end call_editor; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --calledit.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE CALL_EDITOR -- -- File name : CALLEDIT.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- with UR_EDITOR; use UR_EDITOR; with RF_EDITOR; use RF_EDITOR; with TYPE_LIST; use TYPE_LIST; -- package body CALL_EDITOR is -- -- only one procedure within this package -- procedure CALL_THE_EDITOR (MESSAGE_POINTER : in out MESSAGE; DIRECTORY_INFO : in out DIRECTORY_ENTRY; MESSAGE_NUMBER : in out NATURAL) is begin case DIRECTORY_INFO.MESSAGE_TYPE is when RAINFORM => RAINFORM_ED.EDITOR (MESSAGE_POINTER); when UNITREP => UNITREP_ED.EDITOR (MESSAGE_POINTER); end case; end CALL_THE_EDITOR; -- end CALL_EDITOR; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --sdp.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE SYSTEM_DRIVER -- -- File name : SDP.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with GENERAL_MENU_ROUTINES; use GENERAL_MENU_ROUTINES; -- package SYSTEM_DRIVER is -- --this package provides the routines necessary to run --gmhf as a stand_alone or embedded system. the routines are --generally decission makers which determine what actions --are to be taken based on user inputs through the mmi menus. --each routine of this package corresponds to one and only --one menu of the system. --p.s. there is no routine for the edit menu since it is -- included in the edit_function package of gmhf. -- -- -- procedure MAIN_MENU_HANDLER (MENU : in out MENU_NAMES); -- procedure MESSAGE_EDIT_DIRECTORY_MENU_HANDLER (MENU : in out MENU_NAMES); -- procedure MESSAGE_PRINT_DIRECTORY_MENU_HANDLER (MENU : in out MENU_NAMES); -- procedure PROCESS_EDITED_MESSAGE_MENU_HANDLER (MENU : in out MENU_NAMES); -- procedure MESSAGE_DELETE_DIRECTORY_MENU_HANDLER (MENU : in out MENU_NAMES); -- procedure REVIEW_FOR_DELETION_MENU_HANDLER (MENU : in out MENU_NAMES); -- end SYSTEM_DRIVER; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --sdp.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE SYSTEM_DRIVER -- -- File name : SDP.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with FILE_ACCESS; use FILE_ACCESS; with PRINT_PROCEDURES; use PRINT_PROCEDURES; with LINKED_LIST_PROCEDURES; use LINKED_LIST_PROCEDURES; with TYPE_LIST; use TYPE_LIST; with CLASSIFICATION_DEFINITION; use CLASSIFICATION_DEFINITION; with CALL_EDITOR; use CALL_EDITOR; -- -- package body SYSTEM_DRIVER is -- -- this package provides the routines necessary to run -- gmhf as a stand_alone or embedded system. the routines are -- generally decision makers which determine what actions -- are to be taken based on user inputs through the mmi menus. -- each routine of this package corresponds to one and only -- one menu of the system. -- p.s. there is no routine for the edit menu since it is -- included in the edit_function package of gmhf. -- -- package NATURAL_IO is new INTEGER_IO (NATURAL); use NATURAL_IO; -- -- LAST : POSITIVE; SUFFICIENT_DATA : BOOLEAN; -- ACTIVE_MESSAGE : MESSAGE; ACTIVE_MESSAGE_NUMBER : NATURAL; ACTIVE_MESSAGE_TYPE : DIRECTORY_ENTRY; -- -- ----------------------------------- procedure DISPLAY_MESSAGE_DIRECTORY (DIRECTORY : in out DIRECTORY_ENTRY) is ----------------------------------- -- DIRECTORY_POINTER : DIRECTORY_ENTRY; DIRECTORY_DISPLAY_ROW : CRT_ROWS := 6; -- begin -- -- first get the top of the directory -- GET_DIRECTORY (DIRECTORY); -- -- now go through and display elements -- DIRECTORY_POINTER := DIRECTORY; while DIRECTORY_POINTER /= null loop -- -- set pointer to the current type -- if DIRECTORY_DISPLAY_ROW = CRT_ROWS (DIRECTORY_LINE_NUMBER) then DIRECTORY := DIRECTORY_POINTER; end if; -- GOTO_CRT_POSITION (DIRECTORY_DISPLAY_ROW, MESSAGE_TYPE_COLUMN); TYPE_AND_NUMBER_STRING := DIRECTORY_POINTER.TYPE_STRING & DIRECTORY_POINTER.NUMBER_STRING; PUT (TYPE_AND_NUMBER_STRING); -- DIRECTORY_DISPLAY_ROW := DIRECTORY_DISPLAY_ROW + 1; DIRECTORY_POINTER := DIRECTORY_POINTER.NEXT_MESSAGE_TYPE; -- -- boundary check -- exit when DIRECTORY_DISPLAY_ROW > 20; -- end loop; -- GOTO_CRT_POSITION (DIRECTORY_LINE_NUMBER, MESSAGE_TYPE_COLUMN); TYPE_AND_NUMBER_STRING := DIRECTORY.TYPE_STRING & DIRECTORY.NUMBER_STRING; REVERSE_VIDEO_ON; PUT (TYPE_AND_NUMBER_STRING); REVERSE_VIDEO_OFF; -- end DISPLAY_MESSAGE_DIRECTORY; -- -- ----------------------------------------------------------------------- -- here starts the routines for each menu ----------------------------------------------------------------------- --------------------------- procedure MAIN_MENU_HANDLER (MENU : in out MENU_NAMES) is --------------------------- -- -- this routine handles the tabing, commanding etc. of the -- main menu. -- NUMBER_OF_FIELDS : constant INTEGER := 4; VALUES_GOTTEN : STRING_VALUE (1..NUMBER_OF_FIELDS); CURRENT_FIELD : POSITIVE := 1; FIELDS : constant FIELD_ARRAY (1..NUMBER_OF_FIELDS) := (1 => (COMMAND_FIELD, 0, (ROW => 7, COLUMN => 6)), 2 => (COMMAND_FIELD, 0, (ROW => 12, COLUMN => 6)), 3 => (COMMAND_FIELD, 0, (ROW => 17, COLUMN => 6)), 4 => (COMMAND_FIELD, 0, (ROW => 24, COLUMN => 6))); begin loop -- GENERAL_MENU_DRIVER (CURRENT_FIELD, NUMBER_OF_FIELDS, FIELDS, MENU, CURRENT_TYPE, VALUES_GOTTEN); -- if CURRENT_FIELD = 1 then MENU := GMHF_1; elsif CURRENT_FIELD = 2 then MENU := GMHF_2; elsif CURRENT_FIELD = 3 then MENU := GMHF_3; elsif CURRENT_FIELD = 4 then MENU := NONE; end if; -- now exit menu handler exit; -- end loop; -- -- end MAIN_MENU_HANDLER; -- -- --------------------------------------------- procedure MESSAGE_EDIT_DIRECTORY_MENU_HANDLER (MENU : in out MENU_NAMES) is --------------------------------------------- -- -- this routine handles the tabing, commanding etc. of the -- edit directory menu. -- MESSAGE_NUMBER : NATURAL; MESSAGE_POINTER : MESSAGE; NUMBER_OF_FIELDS : constant INTEGER := 9; VALUES_GOTTEN : STRING_VALUE (1..NUMBER_OF_FIELDS) := (others => " "); CURRENT_FIELD : POSITIVE := 1; FIELDS : constant FIELD_ARRAY (1..NUMBER_OF_FIELDS) := (1 => (COMMAND_FIELD, 1, (ROW => 5, COLUMN => 6)), 2 => (DATA_FIELD, 0, (ROW => 5, COLUMN => 23)), 3 => (LIST_FIELD, 0, (ROW => 5, COLUMN => 40)), 4 => (COMMAND_FIELD, 0, (ROW => 9, COLUMN => 6)), 5 => (LIST_FIELD, 0, (ROW => 9, COLUMN => 40)), 6 => (COMMAND_FIELD, 0, (ROW => 13, COLUMN => 6)), 7 => (LIST_FIELD, 0, (ROW => 13, COLUMN => 44)), 8 => (COMMAND_FIELD, 0, (ROW => 19, COLUMN => 6)), 9 => (COMMAND_FIELD, 0, (ROW => 24, COLUMN => 6))); begin DISPLAY_MESSAGE_DIRECTORY (CURRENT_TYPE); LOAD_MESSAGE_TYPE (FIELDS, NUMBER_OF_FIELDS, CURRENT_FIELD, CURRENT_TYPE.TYPE_STRING); -- loop SUFFICIENT_DATA := TRUE; GENERAL_MENU_DRIVER (CURRENT_FIELD, NUMBER_OF_FIELDS, FIELDS, MENU, CURRENT_TYPE, VALUES_GOTTEN); -- for I in 1..FIELDS (CURRENT_FIELD).NUMBER_OF_ASSOCIATES loop if VALUES_GOTTEN (CURRENT_FIELD + I) = " " then SUFFICIENT_DATA := FALSE; PROMPT ("insufficient data for command"); CURRENT_FIELD := CURRENT_FIELD + I; exit; -- exits loop end if; end loop; -- if SUFFICIENT_DATA then -- HERE THE USER WANTS TO EDIT AN EXISTING MESSAGE if CURRENT_FIELD = 1 then GET (VALUES_GOTTEN (2), MESSAGE_NUMBER, LAST); -- converts string to integer if MESSAGE_NUMBER > 0 and MESSAGE_NUMBER <= CURRENT_TYPE.NUMBER_OF_MESSAGES then GET_MESSAGE_OUT (CURRENT_TYPE, MESSAGE_NUMBER, MESSAGE_POINTER); -- -- retain the values of the edited message -- ACTIVE_MESSAGE := MESSAGE_POINTER; ACTIVE_MESSAGE_TYPE := CURRENT_TYPE; ACTIVE_MESSAGE_NUMBER := MESSAGE_NUMBER; -- -- call routine which decides which editor to activate -- CALL_THE_EDITOR (ACTIVE_MESSAGE, ACTIVE_MESSAGE_TYPE, ACTIVE_MESSAGE_NUMBER); -- MENU := GMHF_12; -- process edited message menu exit; else PROMPT (" message number out of range "); CURRENT_FIELD := 2; -- now go back into general_menu_driver end if; -- elsif CURRENT_FIELD = 4 then -- here the user wants to edit a new message MESSAGE_NUMBER := CURRENT_TYPE.NUMBER_OF_MESSAGES + 1; GET_MESSAGE_OUT (CURRENT_TYPE, MESSAGE_NUMBER, MESSAGE_POINTER); -- -- retain the values of the edited message -- ACTIVE_MESSAGE := MESSAGE_POINTER; ACTIVE_MESSAGE_TYPE := CURRENT_TYPE; ACTIVE_MESSAGE_NUMBER := MESSAGE_NUMBER; -- -- call routine which decides which editor to activate -- CALL_THE_EDITOR (ACTIVE_MESSAGE, ACTIVE_MESSAGE_TYPE, ACTIVE_MESSAGE_NUMBER); -- -- MENU := GMHF_12; exit; -- elsif CURRENT_FIELD = 6 then -- here the user wants to edit the prototype message MESSAGE_NUMBER := 0; GET_MESSAGE_OUT (CURRENT_TYPE, MESSAGE_NUMBER, MESSAGE_POINTER); -- -- call routine which decides which editor to activate -- CALL_THE_EDITOR (MESSAGE_POINTER, CURRENT_TYPE, MESSAGE_NUMBER); -- -- and save the message automatically -- PUT_OLD_MESSAGE_BACK_IN (CURRENT_TYPE, MESSAGE_NUMBER, MESSAGE_POINTER); PROMPT ("prototype message modified"); MENU := GMHF_1; exit; -- elsif CURRENT_FIELD = 8 then -- here the user just wants to print the directory PRINT_MESSAGE_DIRECTORY; elsif CURRENT_FIELD = 9 then -- user elects to return to the main menu MENU := GMHF; exit; end if; -- else -- there was insufficient data to process command -- so return to the general_menu_driver null; end if; -- end loop; -- end MESSAGE_EDIT_DIRECTORY_MENU_HANDLER; -- -- ---------------------------------------------- procedure MESSAGE_PRINT_DIRECTORY_MENU_HANDLER (MENU : in out MENU_NAMES) is ---------------------------------------------- -- -- this routine handles the tabing, commanding etc. of the -- print directory menu. -- MESSAGE_NUMBER : NATURAL; FIRST_MESSAGE_NUMBER : NATURAL; LAST_MESSAGE_NUMBER : NATURAL; NUMBER_OF_FIELDS : constant INTEGER := 11; VALUES_GOTTEN : STRING_VALUE (1..NUMBER_OF_FIELDS) := (others => " "); CURRENT_FIELD : POSITIVE := 1; FIELDS : constant FIELD_ARRAY (1..NUMBER_OF_FIELDS) := (1 => (COMMAND_FIELD, 1, (ROW => 5, COLUMN => 6)), 2 => (DATA_FIELD, 0, (ROW => 5, COLUMN => 24)), 3 => (LIST_FIELD, 0, (ROW => 5, COLUMN => 41)), 4 => (COMMAND_FIELD, 2, (ROW => 9, COLUMN => 6)), 5 => (DATA_FIELD, 0, (ROW => 9, COLUMN => 24)), 6 => (DATA_FIELD, 0, (ROW => 9, COLUMN => 46)), 7 => (LIST_FIELD, 0, (ROW => 11, COLUMN => 36)), 8 => (COMMAND_FIELD, 0, (ROW => 15, COLUMN => 6)), 9 => (LIST_FIELD, 0, (ROW => 15, COLUMN => 45)), 10 => (COMMAND_FIELD, 0, (ROW => 19, COLUMN => 6)), 11 => (COMMAND_FIELD, 0, (ROW => 24, COLUMN => 6))); begin DISPLAY_MESSAGE_DIRECTORY (CURRENT_TYPE); LOAD_MESSAGE_TYPE (FIELDS, NUMBER_OF_FIELDS, CURRENT_FIELD, CURRENT_TYPE.TYPE_STRING); loop SUFFICIENT_DATA := TRUE; GENERAL_MENU_DRIVER (CURRENT_FIELD, NUMBER_OF_FIELDS, FIELDS, MENU, CURRENT_TYPE, VALUES_GOTTEN); -- for I in 1..FIELDS (CURRENT_FIELD).NUMBER_OF_ASSOCIATES loop if VALUES_GOTTEN (CURRENT_FIELD + I) = " " then SUFFICIENT_DATA := FALSE; PROMPT ("insufficient data for command"); CURRENT_FIELD := CURRENT_FIELD + I; exit; -- exits loop end if; end loop; -- if SUFFICIENT_DATA then -- if CURRENT_FIELD = 1 then GET (VALUES_GOTTEN (2), MESSAGE_NUMBER, LAST); -- converts string to integer if MESSAGE_NUMBER > 0 and MESSAGE_NUMBER <= CURRENT_TYPE.NUMBER_OF_MESSAGES then PRINT_MESSAGE_TEXT (CURRENT_TYPE, MESSAGE_NUMBER); -- else PROMPT (" message number out of range "); CURRENT_FIELD := 2; -- now go back to the general_menu_driver end if; -- elsif CURRENT_FIELD = 4 then GET (VALUES_GOTTEN (5), FIRST_MESSAGE_NUMBER, LAST); -- converts string to integer if FIRST_MESSAGE_NUMBER > 0 and FIRST_MESSAGE_NUMBER <= CURRENT_TYPE.NUMBER_OF_MESSAGES then -- GET (VALUES_GOTTEN (6), LAST_MESSAGE_NUMBER, LAST); if LAST_MESSAGE_NUMBER > 0 and LAST_MESSAGE_NUMBER <= CURRENT_TYPE.NUMBER_OF_MESSAGES then PRINT_GROUP_OF_MESSAGES (CURRENT_TYPE, FIRST_MESSAGE_NUMBER, LAST_MESSAGE_NUMBER); else PROMPT (" second message number out of range "); CURRENT_FIELD := 6; -- now go back to the general_menu_driver end if; -- else PROMPT (" first message number out of range "); CURRENT_FIELD := 5; -- now go back to the general_menu_driver end if; -- elsif CURRENT_FIELD = 8 then -- print the prototype message MESSAGE_NUMBER := 0; PRINT_MESSAGE_TEXT (CURRENT_TYPE, MESSAGE_NUMBER); -- elsif CURRENT_FIELD = 10 then -- print_directory PRINT_MESSAGE_DIRECTORY; -- elsif CURRENT_FIELD = 11 then -- MENU := GMHF; exit; -- end if; -- else -- there was insufficient data to process command -- so return to the general_menu_driver null; end if; -- end loop; -- end MESSAGE_PRINT_DIRECTORY_MENU_HANDLER; -- -- --------------------------------------------- procedure PROCESS_EDITED_MESSAGE_MENU_HANDLER (MENU : in out MENU_NAMES) is --------------------------------------------- -- -- this routine handles the tabing, commanding etc. of the -- process edited msg menu. -- NUMBER_OF_FIELDS : constant INTEGER := 5; VALUES_GOTTEN : STRING_VALUE (1..NUMBER_OF_FIELDS) := (others => " "); CURRENT_FIELD : POSITIVE := 1; FIELDS : constant FIELD_ARRAY (1..NUMBER_OF_FIELDS) := (1 => (COMMAND_FIELD, 0, (ROW => 12, COLUMN => 6)), 2 => (COMMAND_FIELD, 0, (ROW => 14, COLUMN => 6)), 3 => (COMMAND_FIELD, 0, (ROW => 18, COLUMN => 6)), 4 => (COMMAND_FIELD, 0, (ROW => 20, COLUMN => 6)), 5 => (COMMAND_FIELD, 0, (ROW => 24, COLUMN => 6))); -- -- here starts the main part of the routine -- begin -- GOTO_CRT_POSITION (6, 32); PUT (ACTIVE_MESSAGE_TYPE.TYPE_STRING); PUT (ACTIVE_MESSAGE_NUMBER, 5); -- loop -- GENERAL_MENU_DRIVER (CURRENT_FIELD, NUMBER_OF_FIELDS, FIELDS, MENU, CURRENT_TYPE, VALUES_GOTTEN); -- if CURRENT_FIELD = 1 then -- resave message PUT_OLD_MESSAGE_BACK_IN (ACTIVE_MESSAGE_TYPE, ACTIVE_MESSAGE_NUMBER, ACTIVE_MESSAGE); -- elsif CURRENT_FIELD = 2 then -- save msg as new PUT_NEW_MESSAGE_IN (ACTIVE_MESSAGE_TYPE, ACTIVE_MESSAGE); -- elsif CURRENT_FIELD = 3 then -- re-edit the message -- -- call routine which decides which editor to activate -- CALL_THE_EDITOR (ACTIVE_MESSAGE, ACTIVE_MESSAGE_TYPE, ACTIVE_MESSAGE_NUMBER); -- MENU := GMHF_12; exit; -- elsif CURRENT_FIELD = 4 then MENU := GMHF_1; exit; -- elsif CURRENT_FIELD = 5 then MENU := GMHF; exit; -- end if; -- -- end loop; -- end PROCESS_EDITED_MESSAGE_MENU_HANDLER; -- -- ----------------------------------------------- procedure MESSAGE_DELETE_DIRECTORY_MENU_HANDLER (MENU : in out MENU_NAMES) is ----------------------------------------------- -- -- this routine handles the tabing, commanding etc. of the -- msg delete directory menu. -- MESSAGE_NUMBER : NATURAL; NUMBER_OF_FIELDS : constant INTEGER := 4; VALUES_GOTTEN : STRING_VALUE (1..NUMBER_OF_FIELDS) := (others => " "); CURRENT_FIELD : POSITIVE := 1; FIELDS : constant FIELD_ARRAY (1..NUMBER_OF_FIELDS) := (1 => (COMMAND_FIELD, 1, (ROW => 11, COLUMN => 6)), 2 => (DATA_FIELD, 0, (ROW => 11, COLUMN => 25)), 3 => (LIST_FIELD, 0, (ROW => 11, COLUMN => 41)), 4 => (COMMAND_FIELD, 0, (ROW => 24, COLUMN => 6))); begin DISPLAY_MESSAGE_DIRECTORY (CURRENT_TYPE); LOAD_MESSAGE_TYPE (FIELDS, NUMBER_OF_FIELDS, CURRENT_FIELD, CURRENT_TYPE.TYPE_STRING); -- loop GENERAL_MENU_DRIVER (CURRENT_FIELD, NUMBER_OF_FIELDS, FIELDS, MENU, CURRENT_TYPE, VALUES_GOTTEN); -- SUFFICIENT_DATA := TRUE; for I in 1..FIELDS (CURRENT_FIELD).NUMBER_OF_ASSOCIATES loop if VALUES_GOTTEN (CURRENT_FIELD + I) = " " then SUFFICIENT_DATA := FALSE; PROMPT ("insufficient data for command"); CURRENT_FIELD := CURRENT_FIELD + I; exit; -- exits loop end if; end loop; -- if SUFFICIENT_DATA then if CURRENT_FIELD = 1 then GET (VALUES_GOTTEN (2), MESSAGE_NUMBER, LAST); -- converts string to integer if MESSAGE_NUMBER > 0 and MESSAGE_NUMBER <= CURRENT_TYPE.NUMBER_OF_MESSAGES then ACTIVE_MESSAGE_TYPE := CURRENT_TYPE; ACTIVE_MESSAGE_NUMBER := MESSAGE_NUMBER; GET_MESSAGE_OUT (ACTIVE_MESSAGE_TYPE, ACTIVE_MESSAGE_NUMBER, ACTIVE_MESSAGE); -- MENU := GMHF_31; exit; -- else PROMPT (" message number out of range "); CURRENT_FIELD := 2; -- now go back to the general_menu_driver end if; -- elsif CURRENT_FIELD = 4 then MENU := GMHF; exit; end if; -- else -- there was insufficient data to process comand null; end if; -- end loop; -- end MESSAGE_DELETE_DIRECTORY_MENU_HANDLER; -- -- ------------------------------------------ procedure REVIEW_FOR_DELETION_MENU_HANDLER (MENU : in out MENU_NAMES) is ------------------------------------------ -- -- this routine handles the tabing, commanding etc. of the -- main menu. -- NUMBER_OF_FIELDS : constant INTEGER := 3; VALUES_GOTTEN : STRING_VALUE (1..NUMBER_OF_FIELDS) := (others => " "); CURRENT_FIELD : POSITIVE := 1; FIELDS : constant FIELD_ARRAY (1..NUMBER_OF_FIELDS) := (1 => (COMMAND_FIELD, 0, (ROW => 20, COLUMN => 6)), 2 => (COMMAND_FIELD, 0, (ROW => 22, COLUMN => 6)), 3 => (COMMAND_FIELD, 0, (ROW => 24, COLUMN => 6))); -- -- internal procedures to follow -- ------------------------- procedure DISPLAY_MESSAGE (CURRENT_MESSAGE : in MESSAGE; MESSAGE_NUMBER : in NATURAL; MESSAGE_TYPE : in DIRECTORY_ENTRY) is ------------------------- -- MESSAGE_CONTENT : NODE; LINE_NUMBER : CRT_ROWS := 3; package CLASSIFICATION_IO is new ENUMERATION_IO (CLASSIFICATION); -- begin -- GOTO_CRT_POSITION (LINE_NUMBER, 1); PUT (MESSAGE_TYPE.TYPE_STRING); GOTO_CRT_POSITION (LINE_NUMBER, 30); CLASSIFICATION_IO.PUT (CURRENT_MESSAGE.CLASS); GOTO_CRT_POSITION (LINE_NUMBER, 55); PUT ("Message Number "); PUT (MESSAGE_NUMBER); -- LINE_NUMBER := 5; MESSAGE_CONTENT := CURRENT_MESSAGE.HEAD; START_OF_MSG := CURRENT_MESSAGE.HEAD; TOP_LINE := START_OF_MSG; END_OF_MSG := CURRENT_MESSAGE.TAIL; -- init bottom line incase of 1 line message BOTTOM_LINE := END_OF_MSG; -- loop -- GOTO_CRT_POSITION (LINE_NUMBER, 1); PUT (MESSAGE_CONTENT.TEXT_LINE); LINE_NUMBER := LINE_NUMBER + 1; exit when LINE_NUMBER >= 19; exit when MESSAGE_CONTENT = END_OF_MSG; BOTTOM_LINE := MESSAGE_CONTENT.NEXT_LINE; MESSAGE_CONTENT := MESSAGE_CONTENT.NEXT_LINE; -- end loop; -- end DISPLAY_MESSAGE; -- -- -- here starts the main part of the routine -- begin DISPLAY_MESSAGE (ACTIVE_MESSAGE, ACTIVE_MESSAGE_NUMBER, ACTIVE_MESSAGE_TYPE); loop GENERAL_MENU_DRIVER (CURRENT_FIELD, NUMBER_OF_FIELDS, FIELDS, MENU, CURRENT_TYPE, VALUES_GOTTEN); -- if CURRENT_FIELD = 1 then -- delete the message DELETE_MESSAGE_FROM_DATABASE (ACTIVE_MESSAGE_TYPE, ACTIVE_MESSAGE_NUMBER); PROMPT (" message successfully deleted "); elsif CURRENT_FIELD = 2 then MENU := GMHF_3; exit; elsif CURRENT_FIELD = 3 then MENU := GMHF; exit; end if; -- -- end loop; -- end REVIEW_FOR_DELETION_MENU_HANDLER; -- end SYSTEM_DRIVER; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --gmhf.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE GMHF_DRIVER -- -- File name : GMHF.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with SYSTEM_DRIVER; use SYSTEM_DRIVER; with GENERAL_MENU_ROUTINES; use GENERAL_MENU_ROUTINES; -- procedure GMHF_DRIVER is -- -- NEXT_MENU : MENU_NAMES; MENU : STRING (1..9); -- begin -- driver PUT (ASCII.ESC); PUT ('='); NEXT_MENU := GMHF; loop ERASE_SCREEN; case NEXT_MENU is when GMHF => MENU := " gmhf"; DISPLAY_MENU (MENU); -- the main menu for the system MAIN_MENU_HANDLER (NEXT_MENU); when GMHF_1 => MENU := " gmhf1"; DISPLAY_MENU (MENU); MESSAGE_EDIT_DIRECTORY_MENU_HANDLER (NEXT_MENU); when GMHF_11 => MENU := " gmhf11"; NEXT_MENU := GMHF; -- temporarily when GMHF_12 => MENU := " gmhf12"; DISPLAY_MENU (MENU); PROCESS_EDITED_MESSAGE_MENU_HANDLER (NEXT_MENU); when GMHF_2 => MENU := " gmhf2"; DISPLAY_MENU (MENU); MESSAGE_PRINT_DIRECTORY_MENU_HANDLER (NEXT_MENU); when GMHF_3 => MENU := " gmhf3"; DISPLAY_MENU (MENU); MESSAGE_DELETE_DIRECTORY_MENU_HANDLER (NEXT_MENU); when GMHF_31 => MENU := " gmhf31"; DISPLAY_MENU (MENU); REVIEW_FOR_DELETION_MENU_HANDLER (NEXT_MENU); when others => exit; end case; -- end loop; -- end GMHF_DRIVER; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --extrnusr.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: with linked_list_procedures; use linked_list_procedures; package access_for_external_users is -- -- This package is available for any user who desires to -- utilize the storage and retrieval functions of the -- internal database of GMHF. -- -- type external_message is array(positive range <>) of string(1..80); -- -- provides external access to loading a message for the editor -- procedure load_external_message_into_workspace(class : in string; message_text : in external_message; editable_message : out message); -- -- provides access to retrieving a message from the editor -- procedure retrieve_message_from_workspace(class : out string; message_text : out external_message; editable_message : in message); -- -- provides external access to loading a message -- procedure load_external_message_into_database(class : in string; message_type : in string; message_text : in external_message); -- -- provides access to retrieving a message -- procedure retrieve_message_from_database(class : out string; message_type : in string; message_number : in natural; message_text : out external_message); -- end access_for_external_users; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --extrnusr.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: with linked_list_procedures; use linked_list_procedures; with type_list; use type_list; with classification_definition; use classification_definition; with file_access; use file_access; -- package body access_for_external_users is -- -- This package is available for any user who desires to -- utilize the storage and retrieval functions of the -- internal database of GMHF. -- -- -- provides external access to loading a message for the editor -- ---------------------------------------------- procedure load_external_message_into_workspace(class : in string; message_text : in external_message; editable_message : out message) is ---------------------------------------------- -- external_classification : classification; working_message : message; input_node : node; -- begin -- -- first validate the classification -- external_classification := classification'value(class); -- -- if no constraint error is raised by the VALUE attribute, then -- load the message into the linked list type message -- input_node := new message_component; -- -- initialize the message -- working_message.head := input_node; working_message.tail := input_node; working_message.class := external_classification; working_message.number_of_lines := 1; -- -- and initialize the pointer -- input_node.next_line := null; input_node.prev_line := null; input_node.text_line := message_text(1); -- -- load the linked list -- for index in message_text'first+1 .. message_text'last loop insert_after(working_message,input_node); input_node := input_node.next_line; input_node.text_line := message_text(index); end loop; -- -- return the message -- editable_message := working_message; -- -- end load_external_message_into_workspace; -- -- provides access to retrieving a message from the editor -- ----------------------------------------- procedure retrieve_message_from_workspace(class : out string; message_text : out external_message; editable_message : in message) is ----------------------------------------- -- output_node : node; -- begin -- -- put the message into external format -- output_node := editable_message.head; for index in 1 .. editable_message.number_of_lines loop message_text(index) := output_node.text_line; output_node := output_node.next_line; end loop; -- -- return the classification also -- class := classification'image(editable_message.class); -- -- end retrieve_message_from_workspace; -- -- provides external access to loading a message into database -- --------------------------------------------- procedure load_external_message_into_database(class : in string; message_type : in string; message_text : in external_message) is --------------------------------------------- -- external_classification : classification; external_message_type : available_types; directory_pointer : directory_entry; input_message : message; input_node : node; -- begin -- -- first, validate the classification and message type -- external_classification := classification'value(class); -- external_message_type := available_types'value(message_type); -- -- if no constraint error is raised by the VALUE attribute, then -- create a new message and store it in the database -- input_node := new message_component; -- -- initialize the message -- input_message.head := input_node; input_message.tail := input_node; input_message.class := external_classification; input_message.number_of_lines := 1; -- -- and initialize the pointer -- input_node.next_line := null; input_node.prev_line := null; input_node.text_line := message_text(1); -- -- need to get the directory entry for this message type -- get_directory(directory_pointer); -- -- loop thru the directory until the entry for this type is found -- while directory_pointer.message_type /= external_message_type loop directory_pointer := directory_pointer.next_message_type; end loop; -- -- load the linked list -- for index in message_text'first+1 .. message_text'last loop insert_after(input_message,input_node); input_node := input_node.next_line; input_node.text_line := message_text(index); end loop; -- -- and finally, add the new message -- put_new_message_in(directory_pointer,input_message); -- -- end load_external_message_into_database; -- -- provides access to retrieving a message from database -- ---------------------------------------- procedure retrieve_message_from_database(class : out string; message_type : in string; message_number : in natural; message_text : out external_message) is ---------------------------------------- -- external_message_type : available_types; directory_pointer : directory_entry; output_message : message; output_node : node; -- begin -- -- validate the message type -- external_message_type := available_types'value(message_type); -- -- need to get the directory entry for this message type -- get_directory(directory_pointer); -- -- loop thru the directory until the entry for this type is found -- while directory_pointer.message_type /= external_message_type loop directory_pointer := directory_pointer.next_message_type; end loop; -- -- validate the message number -- if message_number > directory_pointer.number_of_messages then raise constraint_error; end if; -- -- get the message out of the database -- get_message_out(directory_pointer,message_number,output_message); -- -- put the message into external format -- output_node := output_message.head; for index in 1 .. output_message.number_of_lines loop message_text(index) := output_node.text_line; output_node := output_node.next_line; end loop; -- -- return the classification also -- class := classification'image(output_message.class); -- end retrieve_message_from_database; -- -- end access_for_external_users; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --minigfu.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE GENERIC_GET_FIELD_UTILITIES -- -- File name : MINIGFU.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; -- package GENERIC_GET_FIELD_UTILITIES is -- -- this package contains three generic definitions which can be used to -- instantiate input routines to be called by 'Get_field'. The basic -- structure is that we pass an enumerated type as a formal parameter, -- and the other formal parameter is the text_io.enumeration_io.get -- for that enumerated type. If the current compiler supported nested -- generics, we wouldn't have to instantiate the enumeration_io.get -- elsewhere, but could do it within the generic definition given here. -- -- There are three generic definitions. The first can be used to get an -- enumerated field 'as is'. The second can be used to get an enumerated -- field which contains characters which are not allowed in Ada -- identifers but which must be input. The third can be used to get an -- enumerated field some of whose items are Ada keywords. -- -- -- The primary reason for using these generics instead of using only the -- Ada supplied generics is to be consistant with the user interface. In -- particular with capturing command key inputs and to a lesser extent, -- handling exceptions. -- generic type ENUMERATED_TYPE is (<>); with procedure GET_PROC (STR : in STRING; FLD : out ENUMERATED_TYPE; INT : out POSITIVE); procedure GET_ENUMERATED_FIELD (STR : in out STRING; START_OF_FIELD : in POSITIVE; CHARACTERS_GOTTEN : in out POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND); generic type ENUMERATED_TYPE is (<>); with procedure GET_PROC (STR : in STRING; FLD : out ENUMERATED_TYPE; INT : out POSITIVE); procedure GET_B_OR_H_ENUMERATED_FIELD (STR : in out STRING; START_OF_FIELD : in POSITIVE; CHARACTERS_GOTTEN : in out POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND); generic type ENUMERATED_TYPE is (<>); with procedure GET_PROC (STR : in STRING; FLD : out ENUMERATED_TYPE; INT : out POSITIVE); procedure GET_X_ENUMERATED_FIELD (STR : in out STRING; START_OF_FIELD : in POSITIVE; CHARACTERS_GOTTEN : in out POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND); end GENERIC_GET_FIELD_UTILITIES; ----------------------------------------------------------------------- package body GENERIC_GET_FIELD_UTILITIES is procedure GET_ENUMERATED_FIELD (STR : in out STRING; START_OF_FIELD : in POSITIVE; CHARACTERS_GOTTEN : in out POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND) is ERASE_REQUEST : exception; BLANKS : STRING (1..80) := (1..80 => ' '); FIELD_TO_GET : ENUMERATED_TYPE; begin loop begin if COMMAND_FLAG = FALSE then READ (STR, STR'LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); end if; if COMMAND_GOTTEN = ERASE_FIELD then raise ERASE_REQUEST; end if; GET_PROC (STR, FIELD_TO_GET, CHARACTERS_GOTTEN); if CHARACTERS_GOTTEN >= STR'LENGTH then exit; elsif STR (CHARACTERS_GOTTEN + 1..STR'LENGTH) = BLANKS (CHARACTERS_GOTTEN + 1..STR'LENGTH) then exit; else raise DATA_ERROR; end if; exception when DATA_ERROR => PROMPT ("Illegal fixed field data entry. Please reenter data."); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; when END_ERROR => exit; when ERASE_REQUEST => COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); STR (1..STR'LENGTH) := BLANKS (1..STR'LENGTH); PUT (BLANKS (1..STR'LENGTH)); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); when others => PROMPT ("Illegal fixed field data entry. Please try again."); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; end; end loop; end GET_ENUMERATED_FIELD; ----------------------------------------------------------------------- procedure GET_B_OR_H_ENUMERATED_FIELD (STR : in out STRING; START_OF_FIELD : in POSITIVE; CHARACTERS_GOTTEN : in out POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND) is -- ERASE_REQUEST : exception; DUMMY_STRING : STRING (1..20) := (1..20 => ' '); FIELD_TO_GET : ENUMERATED_TYPE; FLAG_A : BOOLEAN := FALSE; UPPER_LOOP : INTEGER; STRING_2_POINTER : POSITIVE := 1; CHARACTER_ADDED_COUNTER : NATURAL := 0; BLANKS : STRING (1..80) := (1..80 => ' '); begin loop begin if COMMAND_FLAG = FALSE then READ (STR, STR'LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); end if; if COMMAND_GOTTEN = ERASE_FIELD then raise ERASE_REQUEST; end if; -- -- change any user entered hyphens or blanks to underscores prior -- to using the enumerated io get -- for I in STR'RANGE loop -- -- ignore leading blanks -- if STR (I) = ' ' and FLAG_A = FALSE then STRING_2_POINTER := STRING_2_POINTER + 1; -- -- handle non-leading blanks -- elsif STR (I) = ' ' and FLAG_A = TRUE then if I = STR'LENGTH then exit; elsif STR (I + 1) = ' ' then exit; else DUMMY_STRING (STRING_2_POINTER..STRING_2_POINTER + 2) := "_B_"; STRING_2_POINTER := STRING_2_POINTER + 3; end if; -- -- handle hyphens -- elsif STR (I) = '-' then FLAG_A := TRUE; DUMMY_STRING (STRING_2_POINTER..STRING_2_POINTER + 2) := "_X_"; STRING_2_POINTER := STRING_2_POINTER + 3; CHARACTER_ADDED_COUNTER := CHARACTER_ADDED_COUNTER + 2; -- -- if not blank or hyphen, copy it into d_s_2 -- else DUMMY_STRING (STRING_2_POINTER) := STR (I); STRING_2_POINTER := STRING_2_POINTER + 1; FLAG_A := TRUE; end if; end loop; -- if STR'LENGTH >= 8 then if STR (1..8) = "41_METER" then DUMMY_STRING (1..12) := "X_41_X_METER"; CHARACTER_ADDED_COUNTER := 4; end if; end if; GET_PROC (DUMMY_STRING, FIELD_TO_GET, CHARACTERS_GOTTEN); if CHARACTERS_GOTTEN >= DUMMY_STRING'LENGTH then exit; elsif DUMMY_STRING (CHARACTERS_GOTTEN + 1..DUMMY_STRING'LENGTH) = BLANKS (CHARACTERS_GOTTEN + 1..DUMMY_STRING'LENGTH) then exit; else raise DATA_ERROR; end if; exception when DATA_ERROR => PROMPT ("Illegal fixed field data entry. Please reenter data."); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; when END_ERROR => exit; when ERASE_REQUEST => COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); STR (1..STR'LENGTH) := BLANKS (1..STR'LENGTH); PUT (BLANKS (1..STR'LENGTH)); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); when others => PROMPT ("Illegal fixed field data entry. Please reenter data."); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; end; end loop; -- end GET_B_OR_H_ENUMERATED_FIELD; ------------------------------------------------ procedure GET_X_ENUMERATED_FIELD (STR : in out STRING; START_OF_FIELD : in POSITIVE; CHARACTERS_GOTTEN : in out POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND) is ERASE_REQUEST : exception; DUMMY_STRING : STRING (1..69) := (1..69 => ' '); FIELD_TO_GET : ENUMERATED_TYPE; STRING_2_POINTER : POSITIVE := 1; CHARACTER_ADDED_COUNTER : NATURAL := 0; BLANKS : STRING (1..80) := (1..80 => ' '); begin loop begin if COMMAND_FLAG = FALSE then READ (STR, STR'LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); end if; if COMMAND_GOTTEN = ERASE_FIELD then raise ERASE_REQUEST; end if; DUMMY_STRING (1..STR'LENGTH) := STR (1..STR'LENGTH); if DUMMY_STRING (1..STR'LENGTH) = BLANKS (1..STR'LENGTH) then exit; end if; for I in 1..STR'LENGTH loop if DUMMY_STRING (1) = ' ' then DUMMY_STRING (1..STR'LENGTH) := DUMMY_STRING (2..STR'LENGTH) & " "; end if; end loop; if STR'LENGTH >= 5 and then DUMMY_STRING (1..5) = "OTHER" then DUMMY_STRING (1..DUMMY_STRING'LENGTH) := "X_" & DUMMY_STRING (1..DUMMY_STRING'LENGTH - 2); elsif STR'LENGTH >= 4 and then DUMMY_STRING (1..4) = "LINE" then DUMMY_STRING (1..DUMMY_STRING'LENGTH) := "X_" & DUMMY_STRING (1..DUMMY_STRING'LENGTH - 2); elsif STR'LENGTH >= 3 and then DUMMY_STRING (1..3) = "OUT" then DUMMY_STRING (1..DUMMY_STRING'LENGTH) := "X_" & DUMMY_STRING (1..DUMMY_STRING'LENGTH - 2); elsif STR'LENGTH >= 2 and then (DUMMY_STRING (1..2) = "AT" or DUMMY_STRING (1..2) = "DO" or DUMMY_STRING (1..2) = "IF" or DUMMY_STRING (1..2) = "IN" or DUMMY_STRING (1..2) = "IS") then DUMMY_STRING (1..DUMMY_STRING'LENGTH) := "X_" & DUMMY_STRING (1..DUMMY_STRING'LENGTH - 2); end if; -- GET_PROC (DUMMY_STRING, FIELD_TO_GET, CHARACTERS_GOTTEN); if CHARACTERS_GOTTEN >= DUMMY_STRING'LENGTH then exit; elsif DUMMY_STRING (CHARACTERS_GOTTEN + 1..DUMMY_STRING'LENGTH) = BLANKS (CHARACTERS_GOTTEN + 1..DUMMY_STRING'LENGTH) then exit; else raise DATA_ERROR; end if; exception when DATA_ERROR => PROMPT ("Illegal fixed field data entry. Please reenter data."); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; when END_ERROR => exit; when ERASE_REQUEST => COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); STR (1..STR'LENGTH) := BLANKS (1..STR'LENGTH); PUT (BLANKS (1..STR'LENGTH)); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); when others => PROMPT ("Illegal fixed field data entry. Please try again."); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; end; end loop; end GET_X_ENUMERATED_FIELD; end GENERIC_GET_FIELD_UTILITIES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --staticgfu.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE STATIC_GET_FIELD_UTILITIES -- -- File name : STATICGFU.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; package STATIC_GET_FIELD_UTILITIES is -- -- The purpose of this package is to provide utilities which can be used -- by Get_field to input numeric fields and calculate checksums. -- -- The primary reason for using these procedures instead of using only -- the Ada supplied routines is to be consistant with the user interface -- in particular with capturing command key inputs and to a lesser -- extent,handling exceptions. type REAL is delta 0.1 range - 999999.9..999999.9; ERASE_ERROR : exception; procedure CHECKSUM (INPUT_DIGITS : in STRING; CHECKSUM_DIGIT : out STRING); procedure GET_CONSTRAINED_INTEGER (STR : in out STRING; START_OF_FIELD : POSITIVE; LOW_LIMIT, HIGH_LIMIT : in INTEGER; FILL_CHARACTER : in CHARACTER; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND); procedure GET_CONSTRAINED_CHARACTER (STR : in out STRING; START_OF_FIELD : POSITIVE; FIRST_CHAR, LAST_CHAR : in CHARACTER; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND; SPACE_ALLOWED : BOOLEAN := FALSE); procedure GET_CONSTRAINED_DECIMAL (STR : in out STRING; START_OF_FIELD : POSITIVE; LOW_LIMIT, HIGH_LIMIT : in REAL; FILL_CHARACTER : in CHARACTER; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND); end STATIC_GET_FIELD_UTILITIES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --staticgfu.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE STATIC_GET_FIELD_UTILITIES -- -- File name : STATICGFU.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; package body STATIC_GET_FIELD_UTILITIES is procedure CHECKSUM (INPUT_DIGITS : in STRING; CHECKSUM_DIGIT : out STRING) is COUNTER : NATURAL := 0; DIGIT_VALUE : NATURAL range 0..9; LAST : POSITIVE; FOUND_A_DIGIT : BOOLEAN := FALSE; DUMMY_STRING : STRING (1..2) := " "; package INT_IO is new INTEGER_IO (INTEGER); begin for I in 1..INPUT_DIGITS'LENGTH loop if INPUT_DIGITS (I) in '0'..'9' then INT_IO.GET (INPUT_DIGITS (I..I), DIGIT_VALUE, LAST); COUNTER := COUNTER + DIGIT_VALUE; FOUND_A_DIGIT := TRUE; end if; end loop; COUNTER := COUNTER mod 10; if FOUND_A_DIGIT = TRUE then DUMMY_STRING := NATURAL'IMAGE (COUNTER); end if; CHECKSUM_DIGIT (1..1) := DUMMY_STRING (2..2); end CHECKSUM; procedure GET_CONSTRAINED_INTEGER (STR : in out STRING; START_OF_FIELD : POSITIVE; LOW_LIMIT, HIGH_LIMIT : in INTEGER; FILL_CHARACTER : in CHARACTER; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND) is -- -- declare some local variables -- package INT_IO is new INTEGER_IO (INTEGER); use INT_IO; subtype CONSTRAINED_INTEGER is INTEGER range LOW_LIMIT..HIGH_LIMIT; TEST_INT : CONSTRAINED_INTEGER; NUMBER_READ : POSITIVE; BLANKS : STRING (1..10) := (1..10 => ' '); -- begin loop -- until no contraint error is raised or alternate exit begin -- a block construct -- -- first read the user input into a string -- if COMMAND_FLAG = FALSE then READ (STR, STR'LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); end if; if COMMAND_GOTTEN = ERASE_FIELD then raise ERASE_ERROR; end if; -- -- now with integer i_o get a integer from the string -- GET (FROM => STR, ITEM => TEST_INT, LAST => NUMBER_READ); -- now see if there is any superfluous data in the field -- if NUMBER_READ = STR'LENGTH then -- no need for any further check. everything is a.o.k. null; elsif STR (NUMBER_READ + 1..STR'LENGTH) /= BLANKS (NUMBER_READ + 1..STR'LENGTH) then raise DATA_ERROR; end if; -- -- now see if the number was with in the ranges -- -- put the integer back into a string and if required pad w/ zeros -- PUT (TO => STR, ITEM => TEST_INT); -- if FILL_CHARACTER = '0' then -- pad with zeros. ( default is padded with blanks) for I in 1..STR'LENGTH loop if STR (I) = ' ' then STR (I) := '0'; end if; end loop; end if; -- exit; -- the block construct -- exception when DATA_ERROR => -- -- if not blank then prompt bad input and go get more -- if STR = BLANKS (1..STR'LENGTH) then exit; else PROMPT (" ILLEGAL INPUT FOR NUMERIC FIELD"); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); end if; when CONSTRAINT_ERROR => -- PROMPT (" NUMBER OUT OF RANGE FOR THIS FIELD "); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); -- when END_ERROR => -- -- all blank and thats o.k. so -- exit; when ERASE_ERROR => raise ERASE_ERROR; end; -- the block construct end loop; -- for reading until good end GET_CONSTRAINED_INTEGER; ----------------------------------------------------- procedure GET_CONSTRAINED_DECIMAL (STR : in out STRING; START_OF_FIELD : POSITIVE; LOW_LIMIT, HIGH_LIMIT : in REAL; FILL_CHARACTER : in CHARACTER; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND) is -- -- define some variables and types -- -- STR2 : STRING (1..STR'LENGTH) := (1..STR'LENGTH => ' '); CHECK_STR : STRING (1..STR'LENGTH + 3) := (1..STR'LENGTH + 3 => ' '); TEST_REAL : REAL; NUMBER_READ : POSITIVE; BLANKS : STRING (1..CHECK_STR'LENGTH) := (1..CHECK_STR'LENGTH => ' '); CHARACTER_FOUND : BOOLEAN; DECIMAL_POINT_FOUND : BOOLEAN; LAST_CHAR_PLACE : INTEGER; DECIMAL_PLACE : INTEGER; TEMP_LENGTH : INTEGER; -- PRECISION_ERROR : exception; package REAL_IO is new FIXED_IO (REAL); use REAL_IO; -- begin loop -- until no exceptions are raised or alternate exit occurs begin -- a block construct -- -- first read the user input into a string -- if COMMAND_FLAG = FALSE then READ (STR, STR'LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); end if; if COMMAND_GOTTEN = ERASE_FIELD then raise ERASE_ERROR; end if; -- -- now c y a by forcing the proper format if its not already -- in it. first search for a decimal point -- CHECK_STR (2..STR'LENGTH + 1) := STR; CHARACTER_FOUND := FALSE; DECIMAL_POINT_FOUND := FALSE; LAST_CHAR_PLACE := 0; DECIMAL_PLACE := 0; -- TEMP_LENGTH := STR'LENGTH + 1; for I in 2..TEMP_LENGTH loop if CHECK_STR (I) /= ' ' then CHARACTER_FOUND := TRUE; LAST_CHAR_PLACE := I; -- if CHECK_STR (I) = '.' then DECIMAL_POINT_FOUND := TRUE; DECIMAL_PLACE := I; end if; -- end if; end loop; -- if DECIMAL_POINT_FOUND then if CHECK_STR (1..DECIMAL_PLACE - 1) = BLANKS (1..DECIMAL_PLACE - 1) then CHECK_STR (DECIMAL_PLACE - 1) := '0'; elsif CHECK_STR (DECIMAL_PLACE + 1..CHECK_STR'LENGTH) = BLANKS (DECIMAL_PLACE + 1..CHECK_STR'LENGTH) then CHECK_STR (DECIMAL_PLACE + 1) := '0'; end if; elsif CHARACTER_FOUND then DECIMAL_PLACE := LAST_CHAR_PLACE + 1; CHECK_STR (LAST_CHAR_PLACE + 1..LAST_CHAR_PLACE + 2) := ".0"; else -- the entry was blank which is o.k. exit; end if; -- -- now make certain there is not too many digits following '.' -- if CHECK_STR (DECIMAL_PLACE + 2) /= ' ' then raise PRECISION_ERROR; end if; -- -- now with real i_o get a real number from the string -- GET (FROM => CHECK_STR, ITEM => TEST_REAL, LAST => NUMBER_READ); -- now see if there is any superfluous data in the field -- if NUMBER_READ = CHECK_STR'LENGTH then -- no need for any further check. everything is a.o.k. null; elsif CHECK_STR (NUMBER_READ + 1..CHECK_STR'LENGTH) /= BLANKS (NUMBER_READ + 1..CHECK_STR'LENGTH) then raise DATA_ERROR; end if; -- -- now check that the number is in the specified range -- if TEST_REAL < LOW_LIMIT or TEST_REAL > HIGH_LIMIT then raise CONSTRAINT_ERROR; end if; -- -- now right justify the string -- LAST_CHAR_PLACE := LAST_CHAR_PLACE - 1; -- for the str variable -- STR2 (STR'LENGTH - LAST_CHAR_PLACE + 1..STR'LENGTH) := STR (1..LAST_CHAR_PLACE); STR := STR2; -- -- and pad with zeros if required if FILL_CHARACTER = '0' then -- pad with zeros. ( default is padded with blanks) for I in 1..STR'LENGTH loop if STR (I) = ' ' then STR (I) := '0'; end if; end loop; end if; -- exit; -- the block construct -- exception when DATA_ERROR => -- -- if not blank then prompt bad input and go get more -- if STR = BLANKS (1..STR'LENGTH) then exit; else PROMPT (" ILLEGAL INPUT FOR NUMERIC FIELD"); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); end if; when CONSTRAINT_ERROR => -- PROMPT (" NUMBER OUT OF RANGE FOR THIS FIELD "); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); -- when PRECISION_ERROR => -- PROMPT (" NUMBER EXCEEDS REQUIRED PRECISION FOR FIELD "); CHECK_STR := (1..STR'LENGTH + 3 => ' '); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); -- when ERASE_ERROR => raise ERASE_ERROR; end; -- the block construct end loop; -- for reading until good -- -- end GET_CONSTRAINED_DECIMAL; -- ----------------------------------------------------- procedure GET_CONSTRAINED_CHARACTER (STR : in out STRING; START_OF_FIELD : POSITIVE; FIRST_CHAR, LAST_CHAR : in CHARACTER; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND; SPACE_ALLOWED : BOOLEAN := FALSE) is -- -- declare some local variables -- subtype CONSTRAINED_CHARACTER is CHARACTER range FIRST_CHAR..LAST_CHAR; TEST_CHAR : CONSTRAINED_CHARACTER; -- begin loop -- until no contraint error is raised or alternate exit begin -- a block construct -- -- first read the user input into a string -- if COMMAND_FLAG = FALSE then READ (STR, STR'LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); end if; if COMMAND_GOTTEN = ERASE_FIELD then raise ERASE_ERROR; end if; -- -- now see if the character was with in the ranges -- by making an assignment. if it was not in the range, -- a constraint error should be raised -- TEST_CHAR := STR (1); -- exit; -- the block construct -- exception when CONSTRAINT_ERROR => -- --if the character is a blank and space allowed thats o.k. -- if STR (1) = ' ' and SPACE_ALLOWED then exit; else PROMPT (" CHARACTER OUT OF RANGE FOR THIS FIELD "); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, START_OF_FIELD); end if; -- when ERASE_ERROR => raise ERASE_ERROR; end; -- the block construct end loop; -- for reading until good end GET_CONSTRAINED_CHARACTER; end STATIC_GET_FIELD_UTILITIES; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --linefield.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: package line_field_lists is -- -- type list_of_lines is ( A, B, C, D, G, J, K, L, M, N, P, Q, T, V, X, R, DM1, DN1, JM1, KF1, KF2, KF3, KF4, KN1, RM3, TF1, H, E, NIL); -- -- -- ALSO, define values for the number of lines, number of characters -- per line, and number of fields per line -- MAXIMUM_FIELDS_PER_LINE : positive := 34; MAXIMUM_CHARACTERS_PER_LINE : positive := 80; MAXIMUM_LINES_PER_MESSAGE : positive := 75; type list_of_fields is (CARD_NUMBER, CLASSIFICATION, UAC, RECORD_ID, UIC, ORIGINATORS_UIC, MESSAGE_TYPE, MESSAGE_NUMBER, UDC, ANAME, UTC, ULC, MJCOM, MAJOR, REVAL, TPSN, SCLAS, LNAME, COAFF, MONOR, CSERV, OPCON, ADCON, HOGEO, PRGEO, EMBRK, ACTIV, FLAG, PUIC, CBCOM, DFCON, POINT, NUCIN, PCTEF, BILET, CORNK, CONAM, MMCMD, NTASK, MODFG, PLETD, NDEST, DETA, CXMRS, TCAA, MEDIA, TADC, ROUTE, RWDTE, XRTE, XDATE, TPERS, PEGEO, STRUC, AUTH, ASGD, POSTR, PICDA, DEPS, TDEPS, CASPW, CCASP, CCEBY, SCATD, MGO, AGO, NA, NFO, MENL, NAVO, NAVE, OTHOF, OTHEN, PIAOD, TREAD, READY, REASN, PRRAT, PRRES, ESRAT, ESRES, ERRAT, ERRES, TRRAT, TRRES, SECRN, TERRN, CARAT, CADAT, LIM, RLIM, RICDA, DOCNR, DOCID, PERTP, TPAUT, TPASG, TPAVL, PERTC, CPAUR, CPASG, CPAVL, TRUTC, TMTHD, TCARQ, TCRAS, TCRAV, TRSA1, TRSA2, TRSA3, TRSA4, TRSA5, EQSEE, EQSSE, MEARD, MEASG, MEPOS, ESSA1, ESSA2, ESSA3, ESSA4, ESSA5, ESSA6, ESSA7, ESSA8, ESSA9, EQREE, EQRED, MEMRA, ERSA1, ERSA2, ERSA3, ERSA4, ERSA5, ERSA6, ERSA7, ERSA8, SDOC, READF, REASF, PRRAF, PRREF, ESRAF, ESREF, ERRAF, ERREF, TRRAF, TRREF, SECRF, TERRF, CARAF, CADAF, LIMF, RLIMF, RICDF, RESPF, SMCC1, SMRA1, SMAA1, SMRC1, SMAC1, SMCC2, SMRA2, SMAA2, SMRC2, SMAC2, SMCC3, SMRA3, SMAA3, SMRC3, SMAC3, SMCC4, SMRA4, SMAA4, SMRC4, SMAC4, GCCLA, GCCLB, GCCLC, SPCLU, PRMA, MARAT, MAREA, CHDAT, FMART, FCDAT, MEQPT, FORDV, MEPSA, METAL, MEPSD, MEORD, MEORN, MEORC, MEORO, CREWA, CREAL, CREWF, CRMRD, CRMRN, CRMRC, CRMRO, MEREC, TEGEO, PIN, FRQNO, PLEAC, DDP, DDPRD, MDT, PUTCV, PEQPT, TPGEO, ALTYP, NUMBR, NUMEA, ALRET, NUSEQ, WPNCO, NUQPT, DSGEO, NUMWR, NUMWB, NUGUN, RTIME, DSSTA, RFGDS, NUSTO, NUECC, SEQ, TOT, LABEL, RMKID, REMRK, TEQPT, MESEN, DECON, MECUS, AVCAT, RESND, ERDTE, EXDAC, CPGEO, CFGEO, EQDEP, EQARR, TPIN, TLEAC, TLEQE, UEQPT, MEQS, SEDY, TEDY, ERRDY, AVAIL, DCNDY, EQRET, GEOGR, OPERL, DAFLD, ACGEO, ACITY, ADATE, MDATE, RDATE, GCMD, TDATE, TRGEO, DEPDT, ARRDT, RPTOR, INTR1, INTR2, SBRPT, ATACH, NOT_USED, H_CARD_NUMBER, DAY_OF_MONTH, MONTH, YEAR, REAL_OR_EXERCISE, NIL ); -- -- end line_field_lists; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --buildfile.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: package BUILD_FILE is -- -- here we will specify a generic routine for building the -- data file which contains the info about each line of a -- given message type. This package need only be used once -- at the instantiation of a new mesage editor. -- -- generic -- -- first pass the list of all lines for the message type -- in the form of an enumerated type. -- -- type LIST_OF_LINES is (<>); -- -- second pass the list of all field names for the message type -- in the form of an enumerated type. -- -- type LIST_OF_FIELDS is (<>); -- -- now pass the total number of characters which the longest line -- of the given message type may be. -- -- MAXIMUM_CHARACTERS_PER_LINE : INTEGER; -- -- now pass the maximum number of fields a line of the given -- type may contain. -- -- MAXIMUM_FIELDS_PER_LINE : INTEGER; -- procedure FILE_BUILDER; -- end BUILD_FILE; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --buildfile.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: with text_io; with direct_io; with line_field_lists; use line_field_lists; -- package body BUILD_FILE is -- -- here we will provide a generic routine for building the -- data file which contains the info about each line of a -- given message type. This package need only be used once -- at the instantiation of a new mesage editor. -- procedure FILE_BUILDER is -- -- first define the identifiers necessary for outputing the data -- to the destination file. -- temp_field_name : list_of_fields := nil; tmp_int : integer; type line_component is record field_name : natural := 0; field_position : natural := 1; field_length : natural := 1; required_flag : boolean := false; end record; -- -- 34 fields is a kludge but good enough for RAINFORM and unitrep type line_component_array is array(1..34) of line_component; -- type line_definition is record number_of_fields : natural := maximum_fields_per_line; prototype_line : string(1..80) := (1..80=> ' '); component : line_component_array ; end record; -- line_info : line_definition; initialized_line_info : line_definition; -- package DESTINATION_IO is new DIRECT_IO( LINE_DEFINITION ); use DESTINATION_IO; destination_file : destination_io.file_type; record_number : destination_io.positive_count; -- -- -- then define the identifiers necessary for reading the source -- file and validating its contents. -- use text_io; package FIELD_IO is new ENUMERATION_IO( LIST_OF_FIELDS ); package LINE_IO is new ENUMERATION_IO( LIST_OF_LINES ); package BOOLEAN_IO is new ENUMERATION_IO( BOOLEAN ); package INT_IO is new INTEGER_IO( INTEGER ); package COUNT_IO is new INTEGER_IO( TEXT_IO.COUNT ); use FIELD_IO; use LINE_IO; use BOOLEAN_IO; use INT_IO; use COUNT_IO; -- filename : string(1..9) := (others => ' '); source_file : text_io.file_type; current_column : text_io.positive_count; current_line_name : list_of_lines; current_position : integer; temp_char : character; proto_started : boolean; source_string : string(1..256); amount : natural; last : positive; front,back : positive; -- BAD_LINE_IN_SOURCE_FILE : exception; -- begin put_line(" "); put_line(" Enter the file name to use for input and output"); put(" .sce and .des will be appended automatically: "); get(filename); -- -- open up the file of which the source data is contained -- text_io.open(source_file,in_file,filename&".sce"); -- -- create the direct access destination file -- begin destination_io.open (destination_file,out_file,filename&".des"); exception when DESTINATION_IO.NAME_ERROR => destination_io.create (destination_file,out_file,filename&".des"); end; -- block consttruct -- -- now set up a loop for reading the info for each line until -- end of file. -- while not end_of_file(source_file) loop -- -- init the line_info record -- line_info := initialized_line_info; -- -- first get the line name as an enumerated type -- loop -- begin get_line(source_file,source_string,amount); for I in 1..AMOUNT loop if SOURCE_STRING(I) /= ' ' then FRONT := I; EXIT; end if; end loop; BACK := AMOUNT; for I in FRONT .. AMOUNT loop if SOURCE_STRING(I) = ' ' or SOURCE_STRING(I) = ',' then BACK := I-1; exit; end if; end loop; -- CURRENT_LINE_NAME := LIST_OF_LINES'value(SOURCE_STRING(FRONT..BACK)); exit; -- exception when CONSTRAINT_ERROR => if source_string(1..2) /= "--" then -- not a comment line so bad put_line(" ERROR READING LINE NAME..."); raise BAD_LINE_IN_SOURCE_FILE; else -- comment line so just go on and read next line null; end if; end; -- block statement end loop; -- -- now get the number of fields for the line -- loop -- begin get_line(source_file,source_string,amount); get(source_string(1..amount),line_info.number_of_fields, last); exit; exception when TEXT_IO.DATA_ERROR => if source_string(1..2) /= "--" then -- not a comment line so bad put_line(" ERROR READING NUMBER OF FIELDS..."); raise BAD_LINE_IN_SOURCE_FILE; else -- comment line so go read next line null; end if; end; -- block statement end loop; -- -- now get the prototype line -- current_position := 1; proto_started := false; -- loop -- get(source_file,temp_char); if temp_char = '"' then -- -- this character either represents the start of a -- prototype line or the end of one -- if not proto_started then -- start of proto proto_started := true; else -- end proto but we may continue on the next line get_line(source_file,source_string,amount); if source_string(1) = '&' then -- we have found a continuation character proto_started := false; else exit; -- loop because we're done with prototype end if; -- end if; -- else -- if not proto_started then -- any character is illegal except space or comment -- if temp_char = ' ' then null; -- every thing is o.k. elsif temp_char = '-' and col(source_file) <= 2 then get(source_file,temp_char); if temp_char = '-' then -- definitely a comment skip_line(source_file); else put_line(" ERROR READING PROTOTYPE LINE... "); skip_line(source_file); raise BAD_LINE_IN_SOURCE_FILE; end if; else put_line(" ERROR READING PROTOTYPE LINE... "); skip_line(source_file); raise BAD_LINE_IN_SOURCE_FILE; end if; -- else -- proto started is true so any ascii character is -- legal -- line_info.prototype_line(current_position) := temp_char; current_position := current_position + 1; -- -- make certain the proto line doesn't get longer -- then allowed -- if current_position > maximum_characters_per_line then skip_line(source_file); exit; -- loop end if; -- end if; -- end if; -- end loop; -- -- now loop for each field and get the info -- for i in 1 .. line_info.number_of_fields loop -- loop -- begin get_line(source_file,source_string,amount); for I in 1..AMOUNT loop if SOURCE_STRING(I) /= ' ' then FRONT := I; EXIT; end if; end loop; BACK := AMOUNT; for I in FRONT .. AMOUNT loop if SOURCE_STRING(I) = ' ' or SOURCE_STRING(I) = ',' then BACK := I-1; exit; end if; end loop; -- TEMP_FIELD_NAME := LIST_OF_FIELDS'value(SOURCE_STRING(FRONT..BACK)); LAST := BACK; -- line_info.component(i).field_name := list_of_fields'pos(temp_field_name); -- get(source_string(last+2..amount), line_info.component(i).field_position,last); -- get(source_string(last+2..amount), line_info.component(i).field_length,last); -- get(source_string(last+2..amount), line_info.component(i).required_flag,last); exit; -- exception when CONSTRAINT_ERROR | TEXT_IO.DATA_ERROR => if source_string(1..2) /= "--" then -- not a comment line so bad put_line(" ERROR READING FIELD INFO... "); raise BAD_LINE_IN_SOURCE_FILE; else -- comment line so just get next line null; end if; end; -- block statement end loop; -- end loop; -- -- now put the info to the direct access destination file. -- put("calculating record number -"); record_number := destination_io.count (list_of_lines'pos(current_line_name) + 1); put(" writing to file "); write(destination_file,line_info,record_number); put_line(" successfully."); -- -- for debug purposes it helps to enable the following -- commented lines -- put_line(" "); put(current_line_name); put_line(" "); -- put(line_info.number_of_fields); -- put_line(" "); -- put_line(line_info.prototype_line); -- for j in 1 .. line_info.number_of_fields loop -- put(line_info.component(j).field_name); -- put(" "); -- put(line_info.component(j).field_position); -- put(" "); -- put(line_info.component(j).field_length); -- put(" "); -- put(line_info.component(j).required_flag); -- put_line(" "); -- end loop; -- -- end loop; -- while not eof -- raise TEXT_IO.END_ERROR; -- -- there are to exceptions we need to handle -- exception when TEXT_IO.DATA_ERROR => -- put(" ERROR IN SOURCE FILE ON LINE #"); put(line(source_file) - 1); put_line("."); -- when TEXT_IO.END_ERROR => -- put(" END OF SOURCE FILE REACHED. "); put(line(source_file) -1); put_line(" LINES PROCESSED."); -- when BAD_LINE_IN_SOURCE_FILE => -- put(" ERROR IN SOURCE FILE ON LINE #"); put(line(source_file) - 1); put_line("."); -- when TEXT_IO.NAME_ERROR => -- put_line(" ERROR IN OPENING SOURCE FILE (name_error)."); -- when TEXT_IO.USE_ERROR => -- put_line(" ERROR IN OPENING SOURCE FILE (use_error)."); -- -- end exceptions end FILE_BUILDER; -- begin null; end BUILD_FILE; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --linemaker.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: with build_file; use build_file; procedure line_maker is -- begin file_builder; end line_maker; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --buildpmt.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: package BUILD_PROMPT_FILE is -- -- here we will specify a routine for building the -- data file which contains the info about each prompt of a -- given message type. This package need only be used once -- at the instantiation of a new mesage editor. -- procedure PROMPT_FILE_BUILDER( maximum_characters_per_line : in integer; max_amp_lines : in integer); -- end BUILD_PROMPT_FILE; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --pmtmaker.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: with build_prompt_file; use build_prompt_file; procedure prompt_maker is -- begin prompt_file_builder(80,5); end prompt_maker; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --buildlut.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: package BUILD_LUT is -- -- here we will specify a generic routine for building the -- data file which contains the info about each line of a -- given message type. This package need only be used once -- at the instantiation of a new mesage editor. -- -- generic -- -- first pass the list of all lines for the message type -- in the form of an enumerated type. -- -- type LIST_OF_LINES is (<>); -- -- now pass the maximum number of fields a line of the given -- type may contain. -- -- MAXIMUM_FIELDS_PER_LINE : INTEGER; -- procedure LUT_BUILDER; -- end BUILD_LUT; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --buildlut.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: with text_io; with direct_io; with line_field_lists; use line_field_lists; -- package body BUILD_LUT is -- -- here we will provide a generic routine for building the -- data file which contains the info about each line of a -- given message type. This package need only be used once -- at the instantiation of a new mesage editor. -- procedure LUT_BUILDER is -- -- first define the identifiers necessary for outputing the data -- to the destination file. -- tmp_int : integer; type lut_component is array(1..34) of integer; -- lut_info : lut_component; initialized_lut_info : lut_component := (others => 0); -- package DESTINATION_IO is new DIRECT_IO( lut_component ); use DESTINATION_IO; destination_file : destination_io.file_type; record_number : destination_io.positive_count; -- -- -- then define the identifiers necessary for reading the source -- file and validating its contents. -- use text_io; package LINE_IO is new ENUMERATION_IO( LIST_OF_LINES ); package INT_IO is new INTEGER_IO( INTEGER ); package COUNT_IO is new INTEGER_IO( TEXT_IO.COUNT ); use LINE_IO; use INT_IO; use COUNT_IO; -- filename : string(1..9); source_file : text_io.file_type; current_column : text_io.positive_count; current_line_name : list_of_lines; current_position : integer; temp_char : character; source_string : string(1..256); blanks : string(1..256) := (others => ' '); amount : natural; last : positive; front,back : positive; start_pos : positive; -- BAD_LINE_IN_SOURCE_FILE : exception; -- begin -- put_line(" "); put_line(" Enter the file name to use for input and output"); put(" .sce and .des will be appended automatically: "); get(filename); -- -- open up the file of which the source data is contained -- text_io.open(source_file,in_file,filename&".sce"); -- -- create the direct access destination file -- begin destination_io.open (destination_file,out_file,filename&".des"); exception when DESTINATION_IO.NAME_ERROR => destination_io.create (destination_file,out_file,filename&".des"); when DESTINATION_IO.STATUS_ERROR => destination_io.create (destination_file,out_file,filename&".des"); end; -- block construct -- -- now set up a loop for reading the info for each line until -- end of file. -- record_number := 1; -- while not end_of_file(source_file) loop -- -- init the lut_info record -- lut_info := initialized_lut_info; -- -- first get the line name as an enumerated type -- loop -- begin get_line(source_file,source_string,amount); for I in 1 .. AMOUNT loop if SOURCE_STRING(I) /= ' ' then FRONT := I; exit; end if; end loop; BACK := AMOUNT; for I in FRONT .. AMOUNT loop if SOURCE_STRING(I) = ' ' or SOURCE_STRING(I) = ',' then BACK := I-1; exit; end if; end loop; LAST := BACK; CURRENT_LINE_NAME := LIST_OF_LINES'value(SOURCE_STRING(FRONT .. BACK)); exit; -- exception when CONSTRAINT_ERROR => if source_string(1..2) /= "--" then -- not a comment line so bad or special if record_number = 1 then last := 7; exit; -- special line else put_line(" ERROR READING LINE NAME..."); raise BAD_LINE_IN_SOURCE_FILE; end if; else -- comment line so just go on and read next line null; end if; end; -- block statement end loop; -- -- now get the lut entry for each field of the line -- for i in 1 .. 34 loop -- begin -- start_pos := last + 2; if start_pos <= amount then get(source_string(start_pos..amount),lut_info(i),last); else exit; end if; exception when TEXT_IO.DATA_ERROR => if source_string(start_pos..amount) = blanks(start_pos..amount) then exit; else raise BAD_LINE_IN_SOURCE_FILE; end if; end; -- block statement end loop; -- -- now put the info to the direct access destination file. -- put("calculating record number -"); if record_number = 1 then write(destination_file,lut_info,record_number); record_number := 2; else record_number := destination_io.count (list_of_lines'pos(current_line_name) + 2); write(destination_file,lut_info,record_number); end if; -- -- -- end loop; -- while not eof -- raise TEXT_IO.END_ERROR; -- -- there are to exceptions we need to handle -- exception when TEXT_IO.DATA_ERROR => -- put(" ERROR IN SOURCE FILE ON LINE #"); put(line(source_file) - 1); put_line("."); -- when TEXT_IO.END_ERROR => -- put(" END OF SOURCE FILE REACHED. "); put(line(source_file) -1); put_line(" LINES PROCESSED."); -- when BAD_LINE_IN_SOURCE_FILE => -- put(" ERROR IN SOURCE FILE ON LINE #"); put(line(source_file) - 1); put_line("."); -- when TEXT_IO.NAME_ERROR => -- put_line(" ERROR IN OPENING SOURCE FILE (name_error)."); -- when TEXT_IO.USE_ERROR => -- put_line(" ERROR IN OPENING SOURCE FILE (use_error)."); -- -- end exceptions end LUT_BUILDER; -- begin null; end BUILD_LUT; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --lutmaker.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: with build_lut; use build_lut; procedure lut_maker is -- begin lut_builder; end lut_maker; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --buildpmt.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: with text_io; with direct_io; with terminal_definition; use terminal_definition; -- package body BUILD_PROMPT_FILE is -- -- here we will provide a generic routine for building the -- data file which contains the info about each line of a -- given message type. This package need only be used once -- at the instantiation of a new mesage editor. -- procedure PROMPT_FILE_BUILDER( maximum_characters_per_line : in integer; max_amp_lines : in integer) is -- -- first define the identifiers necessary for outputing the data -- to the destination file. -- type amp_component is record location: crt_position := (row => 2, column => 1); amp : string(1..80) := (1..80 => ' '); end record; -- type amp_component_array is array(1..max_amp_lines) of amp_component; -- type prompt_definition is record prompt_line_length : integer := 0; prompt_line : string(1..80) := (1..80 => ' '); number_of_amp_lines : natural := max_amp_lines; component : amp_component_array ; end record; -- prompt_info : prompt_definition; initialized_prompt_info : prompt_definition; -- package DESTINATION_IO is new DIRECT_IO( prompt_definition ); use DESTINATION_IO; destination_file : destination_io.file_type; record_number : destination_io.positive_count; -- -- -- then define the identifiers necessary for reading the source -- file and validating its contents. -- use text_io; package INT_IO is new INTEGER_IO( INTEGER ); package COUNT_IO is new INTEGER_IO( TEXT_IO.COUNT ); use INT_IO; use COUNT_IO; -- filename : string(1..9); prompt_started : boolean; amp_started : boolean; source_file : text_io.file_type; current_column : text_io.positive_count; current_position : integer; temp_char : character; source_string : string(1..256); amount : natural; last : positive; next_char : positive; -- BAD_LINE_IN_SOURCE_FILE : exception; -- begin put_line(" "); put_line(" Enter the file name to use for input and output"); put(" .sce and .des will be appended automatically: "); get(filename); -- -- open up the file of which the source data is contained -- text_io.open(source_file,in_file,filename&".sce"); -- -- create the direct access destination file -- begin destination_io.open (destination_file,out_file,filename&".des"); exception when DESTINATION_IO.NAME_ERROR => destination_io.create (destination_file,out_file,filename&".des"); end; -- block consttruct -- -- now set up a loop for reading the info for each line until -- end of file. -- record_number := 1; while not end_of_file(source_file) loop -- -- init the prompt_info record -- prompt_info := initialized_prompt_info; -- -- now get the prompttype line -- current_position := 1; prompt_started := false; -- loop -- get(source_file,temp_char); if temp_char = '"' then -- -- this character either represents the start of a -- prompt or the end of one -- if not prompt_started then -- start of prompt prompt_started := true; else -- end prompt but we may continue on the next line get_line(source_file,source_string,amount); if source_string(1) = '&' then -- we have found a continuation character prompt_started := false; else exit; -- loop because we're done with prompt end if; -- end if; -- else -- if not prompt_started then -- any character is illegal except space or comment -- if temp_char = ' ' then null; -- every thing is o.k. elsif temp_char = '-' and col(source_file) <= 2 then get(source_file,temp_char); if temp_char = '-' then -- definitely a comment skip_line(source_file); else put_line(" ERROR READING PROMPT LINE... "); skip_line(source_file); raise BAD_LINE_IN_SOURCE_FILE; end if; else put_line(" ERROR READING PROMPT LINE... "); skip_line(source_file); raise BAD_LINE_IN_SOURCE_FILE; end if; -- else -- prompt started is true so any ascii character is -- legal -- prompt_info.prompt_line(current_position) := temp_char; current_position := current_position + 1; -- -- make certain the prompt line doesn't get longer -- then allowed -- if current_position > maximum_characters_per_line then skip_line(source_file); exit; -- loop end if; -- end if; -- end if; -- end loop; prompt_info.prompt_line_length := current_position - 1; -- -- now get the number of amps for the prompt -- loop -- begin get_line(source_file,source_string,amount); get(source_string(1..amount), prompt_info.number_of_amp_lines,last); exit; exception when TEXT_IO.DATA_ERROR => if source_string(1..2) /= "--" then -- not a comment line so bad put_line(" ERROR READING NUMBER OF AMPS..."); raise BAD_LINE_IN_SOURCE_FILE; else -- comment line so go read next line null; end if; end; -- block statement end loop; -- -- now loop for each field and get the info -- for i in 1 .. prompt_info.number_of_amp_lines loop -- loop -- begin get_line(source_file,source_string,amount); get(source_string(1..amount), prompt_info.component(i).location.row,last); -- get(source_string(last+2..amount), prompt_info.component(i).location.column,last); -- current_position := 1; amp_started := false; -- next_char := last + 2; loop -- temp_char := source_string(next_char); next_char := next_char + 1; if temp_char = '"' then -- -- this character either represents the start of -- amp or the end of one -- if not amp_started then -- start of amp amp_started := true; else exit; -- loop because we done with prompt -- end if; -- else -- if not amp_started then -- any character is illegal except space or -- comment -- if temp_char = ' ' then null; -- every thing is o.k. elsif temp_char = '-' and col(source_file) <= 2 then -- temp_char := source_string(next_char); next_char := next_char + 1; if temp_char = '-' then -- definitely a comment skip_line(source_file); else put_line(" ERROR READING AMP LINE... "); skip_line(source_file); raise BAD_LINE_IN_SOURCE_FILE; end if; else put_line(" ERROR READING AMP LINE... "); skip_line(source_file); raise BAD_LINE_IN_SOURCE_FILE; end if; -- else -- prompt started is true so any ascii -- character is legal -- prompt_info.component(i).amp(current_position) := temp_char; current_position := current_position + 1; -- -- make certain the prompt line doesn't get -- longer then allowed -- if current_position > maximum_characters_per_line then skip_line(source_file); exit; -- loop end if; -- end if; -- end if; -- end loop; exit; -- exception when TEXT_IO.DATA_ERROR => if source_string(1..2) /= "--" then -- not a comment line so bad put_line(" ERROR READING FIELD INFO... "); raise BAD_LINE_IN_SOURCE_FILE; else -- comment line so just get next line null; end if; end; -- block statement end loop; -- end loop; -- -- now put the info to the direct access destination file. -- put(" writing to file "); write(destination_file,prompt_info,record_number); put_line(" successfully."); record_number := record_number + 1; -- -- end loop; -- while not eof -- raise TEXT_IO.END_ERROR; -- -- there are to exceptions we need to handle -- exception when TEXT_IO.DATA_ERROR => -- put(" ERROR IN SOURCE FILE ON LINE #"); put(line(source_file) - 1); put_line("."); -- when TEXT_IO.END_ERROR => -- put(" END OF SOURCE FILE REACHED. "); put(line(source_file) -1); put_line(" LINES PROCESSED."); -- when BAD_LINE_IN_SOURCE_FILE => -- put(" ERROR IN SOURCE FILE ON LINE #"); put(line(source_file) - 1); put_line("."); -- when TEXT_IO.NAME_ERROR => -- put_line(" ERROR IN OPENING SOURCE FILE (name_error)."); -- when TEXT_IO.USE_ERROR => -- put_line(" ERROR IN OPENING SOURCE FILE (use_error)."); -- -- end exceptions end PROMPT_FILE_BUILDER; -- begin null; end BUILD_PROMPT_FILE; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --dirbuild.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PROCEDURE DIRECTORY_BUILD -- -- File name : DIRBUILD.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- ----------------------------------------------------------------------- -- -- This procedure is necessary to create a new version of the internal -- message data base directory. -- ----------------------------------------------------------------------- with text_io; use text_io; with type_list; use type_list; with calendar; with direct_io; procedure directory_build is -- type classification is (unclassified); -- type directory_structure; type directory_entry is access directory_structure; -- type directory_structure is record message_type : available_types; message_filename : string(1..9); number_of_messages : integer; previous_message_type : directory_entry; next_message_type : directory_entry; type_string : string ( 1 .. 11 ); number_string : string ( 1 .. 5 ); end record; -- current_record : directory_structure; -- package dir_io is new direct_io(directory_structure);use dir_io; file_1 : dir_io.file_type; record_number : dir_io.positive_count := 1; -- -- type msg_format is array(1..25) of string(1..80); type message_record is record class : classification; number_of_lines : positive; month,day,year : integer; content : msg_format; end record; -- package msg_io is new direct_io(message_record);use msg_io; file_2 : msg_io.file_type; -- msg_data : message_record; -- package message_type_io is new enumeration_io(available_types); use message_type_io; package natural_io is new integer_io(natural); use natural_io; -- compute_time : calendar.time; month, day, year : integer; -- begin -- compute_time := calendar.clock; -- month := calendar.month(compute_time); day := calendar.day(compute_time); year := calendar.year(compute_time); -- -- -- fill a message record with default prototype message format -- msg_data.class := unclassified; msg_data.number_of_lines := 1; msg_data.month := month; msg_data.day := day; msg_data.year := year; -- -- create the directory file -- put_line( "Creating the message directory file entries and files for :"); put_line(" "); create(file_1,inout_file,"MSGDRCTRY.DAT",""); -- -- loop on available types -- for msg_type in available_types'first .. available_types'last loop -- put(msg_type);put_line(" "); -- case msg_type is -- when rainform => -- msg_data.content(1) := "NARR/ Prototype message line "& " "; -- when unitrep => -- msg_data.content(1) := " A "& " "; -- when others => -- msg_data.content(1) := " "& " "; -- end case; -- current_record.message_type := msg_type; put( to => current_record.message_filename, item => msg_type); current_record.number_of_messages := 0; put( to => current_record.type_string, item => msg_type ); put( to => current_record.number_string, item => current_record.number_of_messages ); -- write(file_1,current_record,record_number); -- -- create a msg file and load the first record -- create(file_2,inout_file, current_record.message_filename&".msg",""); write(file_2,msg_data,1); close(file_2); -- record_number := record_number + 1; end loop; -- -- close the file -- close(file_1); -- put_line(" ");put_line(" ");put_line(" "); put_line("File creation complete ..."); -- end directory_build; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --lnsandfds.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE MINI_LINES_AND_FIELDS -- -- File name : LNSANDFDS.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; package MINI_LINES_AND_FIELDS is -- -- this package contains the line type and field type definitions for -- the unclassified version of the Rainform instance. In addition, it -- defines a subtype of the set of lines. The subtype is required so -- that parse line type can correctly identify an 'incoming' line -- type. Several types of lines have multiple forms, eg. AREA. -- Therefore we define each of the different forms by subscripting -- with a 'qualifier'. However, when the line is actually parsed, the -- qualifier will not be present. Thus we need the line name in its -- 'pure' form for the parser. -- type UNCLASSIFIED_RAINFORM_LINES is (ACFT, ADD, AFTER, ALT, AMBTN, AREA_LL, AREA_C, AREA_A, ASSOC, BATHY, CHG, CREW, DELET, ELLIP_R, ELLIP_A, EMCON, ENDAT, FLTTM, GRID, LAMP, NARR, POSEL, RMKS, ROUTE_LL, ROUTE_LP, ROUTE_PL, ROUTE_PP, SECT, TIMPD, TRACK_LL, TRACK_N, TRAIN, WEA, WEX, FREE, AREA, ELLIP, ROUTE, TRACK); subtype USED_RAINFORM_LINES is UNCLASSIFIED_RAINFORM_LINES range ACFT..WEX; type SUBSET_OF_RAINFORM_FIELDS is ( -- -- first the composite and constrained field types -- ALTITUDE_LIMITS, BEARING, COMMENT, DATE_TIME_GROUP, DECIMAL_DIGITS, DIGITAL, DIGITAL_BIG, FILLED_DIGITS, FLT_TIME, FREQUENCY, GRID_POINT, LATITUDE, LONGITUDE, OTHER_ALT, PC_OR_TC, SCORE, TEMPERATURE, WEX_TEMP, -- -- now the enumeration types -- FLIGHT_TIME_CATEGORY, MEAN_SEA_LEVEL, MONTH, PAD, TURBULENCE, TYPE_CHANGE, TYPE_CLOUDS, UNITS, WEATHER, NIL ); type FLIGHT_TIME_CATEGORY_TYPE is (PILOT, PNATOPS, PPIP, INSTR, ACCEP, FERRY, LAL, ARFAM, AIRWAYS, ADMIN, TNATOPS, CNATOPS, X_OTHER ); type MEAN_SEA_LEVEL_TYPE is (MSL ); type MONTH_TYPE is (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, SEP, OCT, NOV, DEC ); type PAD_TYPE is (X_OUT, X_IN ); type TURBULENCE_TYPE is (NON, LGT, MDT, SEV, EXT ); type TYPE_CHANGE_TYPE is (CANCEL, REPLACE, CORRECTION ); type TYPE_CLOUDS_TYPE is (ST, SC, CU, CB, AS, AC, CI ); type UNITS_TYPE is (MET, ENG ); type WEATHER_TYPE is (R, HR, LR, RW, HRW, LRW, TS, HTS, LTS, ZR, HZR, LZR, L, ZL, S, HS, LS, SW, HSW, LSW, A, HA, LA, F, HF, LF, GF, HGF, LGF, X_IF, HIF, LIF, H, HH, LH, K, HK, LK, D, HD, LD, CLR ); -- -- here we the enumerated types which are used as components within -- fields -- type CARDINAL_POINT is (N, S, E, W ); subtype NS_CARDINAL is CARDINAL_POINT range N..S; subtype EW_CARDINAL is CARDINAL_POINT range E..W; type PC_TC is (PC, TC ); type AL_OR_FL is (AL, FL ); end MINI_LINES_AND_FIELDS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --subgrf1.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE SUB_PKG_1 -- -- File name : SUBGRF1.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with MINI_LINES_AND_FIELDS; use MINI_LINES_AND_FIELDS; with GENERIC_GET_FIELD_UTILITIES; use GENERIC_GET_FIELD_UTILITIES; package SUB_PKG_1 is -- -- this package is required due to Telesoft size limitations. -- here we instantiate input routines for several enumerated -- types, and define an input routine - grf_sub_1 - which -- stands for Get_Rainform_Subroutine_1 and is called by -- get_Rainform_field. The instantiations are based upon generic -- definitions found in generic_get_field_utilities. -- package ENUM1 is new ENUMERATION_IO (FLIGHT_TIME_CATEGORY_TYPE); procedure GET_FLIGHT_TIME is new GET_X_ENUMERATED_FIELD (ENUMERATED_TYPE => FLIGHT_TIME_CATEGORY_TYPE, GET_PROC => ENUM1.GET); package ENUM2 is new ENUMERATION_IO (MEAN_SEA_LEVEL_TYPE); procedure GET_MSL is new GET_ENUMERATED_FIELD (ENUMERATED_TYPE => MEAN_SEA_LEVEL_TYPE, GET_PROC => ENUM2.GET); package ENUM3 is new ENUMERATION_IO (MONTH_TYPE); procedure GET_MONTH is new GET_ENUMERATED_FIELD (ENUMERATED_TYPE => MONTH_TYPE, GET_PROC => ENUM3.GET); procedure GRF_SUB_1 (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND); end SUB_PKG_1; package body SUB_PKG_1 is procedure GRF_SUB_1 (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND) is LAST : POSITIVE; begin -- case FIELD_TYPE is -- when FLIGHT_TIME_CATEGORY => GET_FLIGHT_TIME (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); -- when MEAN_SEA_LEVEL => GET_MSL (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); -- when MONTH => GET_MONTH (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); when others => null; -- end case; end GRF_SUB_1; end SUB_PKG_1; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --subgrf2.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE SUB_PKG_2 -- -- File name : SUBGRF2.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with MINI_LINES_AND_FIELDS; use MINI_LINES_AND_FIELDS; with GENERIC_GET_FIELD_UTILITIES; use GENERIC_GET_FIELD_UTILITIES; package SUB_PKG_2 is -- -- this package is required due to Telesoft size limitations. -- here we instantiate input routines for several enumerated -- types, and define an input routine - grf_sub_2 - which -- stands for Get_Rainform_Subroutine_2 and is called by -- get_Rainform_field. The instantiations are based upon generic -- definitions found in generic_get_field_utilities. -- package ENUM7 is new ENUMERATION_IO (TYPE_CLOUDS_TYPE); procedure GET_CLOUDS is new GET_ENUMERATED_FIELD (ENUMERATED_TYPE => TYPE_CLOUDS_TYPE, GET_PROC => ENUM7.GET); package ENUM8 is new ENUMERATION_IO (UNITS_TYPE); procedure GET_UNITS is new GET_ENUMERATED_FIELD (ENUMERATED_TYPE => UNITS_TYPE, GET_PROC => ENUM8.GET); package ENUM13 is new ENUMERATION_IO (AL_OR_FL); procedure GET_AL_OR_FL is new GET_X_ENUMERATED_FIELD (ENUMERATED_TYPE => AL_OR_FL, GET_PROC => ENUM13.GET); procedure GRF_SUB_2 (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND); end SUB_PKG_2; package body SUB_PKG_2 is procedure GRF_SUB_2 (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND) is LAST : POSITIVE; begin case FIELD_TYPE is -- when TYPE_CLOUDS => GET_CLOUDS (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); when UNITS => GET_UNITS (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); when OTHER_ALT => GET_AL_OR_FL (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); when others => null; -- end case; end GRF_SUB_2; end SUB_PKG_2; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --subgrf3.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE SUB_PKG_3 -- -- File name : SUBGRF3.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with MINI_LINES_AND_FIELDS; use MINI_LINES_AND_FIELDS; with GENERIC_GET_FIELD_UTILITIES; use GENERIC_GET_FIELD_UTILITIES; with STATIC_GET_FIELD_UTILITIES; use STATIC_GET_FIELD_UTILITIES; package SUB_PKG_3 is -- -- this package is required due to Telesoft size limitations. -- here we instantiate input routines for several enumerated -- types, and define an input routine - grf_sub_3 - which -- stands for Get_Rainform_Subroutine_3 and is called by -- get_Rainform_field. The instantiations are based upon generic -- definitions found in generic_get_field_utilities. -- package ENUM9 is new ENUMERATION_IO (WEATHER_TYPE); procedure GET_WEATHER is new GET_X_ENUMERATED_FIELD (ENUMERATED_TYPE => WEATHER_TYPE, GET_PROC => ENUM9.GET); package ENUM12 is new ENUMERATION_IO (PC_TC); procedure GET_PC_TC is new GET_ENUMERATED_FIELD (ENUMERATED_TYPE => PC_TC, GET_PROC => ENUM12.GET); procedure GRF_SUB_3 (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND); end SUB_PKG_3; package body SUB_PKG_3 is procedure GRF_SUB_3 (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND) is LAST : POSITIVE; begin case FIELD_TYPE is when WEATHER => GET_WEATHER (FIELD_GOTTEN (1..3), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); when PC_OR_TC => GET_PC_TC (FIELD_GOTTEN (1..2), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); -- when BEARING => GET_CONSTRAINED_DECIMAL (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, 0.0, 359.9, '0', COMMAND_FLAG, COMMAND_GOTTEN); -- when DECIMAL_DIGITS => GET_CONSTRAINED_DECIMAL (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, 0.0, 100.0, ' ', COMMAND_FLAG, COMMAND_GOTTEN); -- when DIGITAL => DIGITAL_BLOCK : declare UPPER_LIMIT : INTEGER; begin UPPER_LIMIT := 10 ** (FIELD_LENGTH) - 1; GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, 0, UPPER_LIMIT, ' ', COMMAND_FLAG, COMMAND_GOTTEN); end DIGITAL_BLOCK; -- when DIGITAL_BIG => for INDEX in 1..FIELD_LENGTH loop GET_CONSTRAINED_CHARACTER (FIELD_GOTTEN (INDEX..INDEX), FIELD_POSITION, '0', '9', COMMAND_FLAG, COMMAND_GOTTEN); end loop; -- when FILLED_DIGITS => FILLED_DIGITS_BLOCK : declare UPPER_LIMIT : INTEGER; begin UPPER_LIMIT := 10 ** (FIELD_LENGTH) - 1; GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, 0, UPPER_LIMIT, '0', COMMAND_FLAG, COMMAND_GOTTEN); end FILLED_DIGITS_BLOCK; -- when FLT_TIME => GET_CONSTRAINED_DECIMAL (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, 0.0, 9999.9, ' ', COMMAND_FLAG, COMMAND_GOTTEN); -- when FREQUENCY => GET_CONSTRAINED_DECIMAL (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, 0.0, 9999.0, ' ', COMMAND_FLAG, COMMAND_GOTTEN); -- when SCORE => GET_CONSTRAINED_DECIMAL (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, 0.0, 100.0, '0', COMMAND_FLAG, COMMAND_GOTTEN); -- when TEMPERATURE => GET_CONSTRAINED_DECIMAL (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, 0.0, 99.9, '0', COMMAND_FLAG, COMMAND_GOTTEN); -- when WEX_TEMP => GET_CONSTRAINED_DECIMAL (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, 0.0, 99.9, ' ', COMMAND_FLAG, COMMAND_GOTTEN); -- when others => null; -- end case; exception when ERASE_ERROR => COMMAND_FLAG := TRUE; COMMAND_GOTTEN := ERASE_FIELD; when others => COMMAND_FLAG := TRUE; COMMAND_GOTTEN := ERASE_FIELD; end GRF_SUB_3; end SUB_PKG_3; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --subgrf4.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE SUB_PKG_4 -- -- File name : SUBGRF4.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with MINI_LINES_AND_FIELDS; use MINI_LINES_AND_FIELDS; with GENERIC_GET_FIELD_UTILITIES; use GENERIC_GET_FIELD_UTILITIES; with STATIC_GET_FIELD_UTILITIES; use STATIC_GET_FIELD_UTILITIES; package SUB_PKG_4 is package ENUM10 is new ENUMERATION_IO (NS_CARDINAL); procedure GET_NS is new GET_ENUMERATED_FIELD (ENUMERATED_TYPE => NS_CARDINAL, GET_PROC => ENUM10.GET); package ENUM11 is new ENUMERATION_IO (EW_CARDINAL); procedure GET_EW is new GET_ENUMERATED_FIELD (ENUMERATED_TYPE => EW_CARDINAL, GET_PROC => ENUM11.GET); procedure GRF_SUB_4 (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND); end SUB_PKG_4; package body SUB_PKG_4 is procedure GRF_SUB_4 (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND) is LAST : POSITIVE := 1; DUMMY_STRING : STRING (1..20) := (1..20 => ' '); BLANK_FLAG : BOOLEAN; NON_BLANK_FLAG : BOOLEAN; procedure CHECK_FOR_BLANKS (LENGTH : in NATURAL) is begin -- -- the purpose of this routine is to determine whether a field -- which should be all blank is in fact all blank, or whether a -- field which should contain no blanks actually has some. -- if LENGTH = 1 then return; end if; for I in 2..LENGTH loop if FIELD_GOTTEN (I) /= ' ' then if BLANK_FLAG = TRUE then raise DATA_ERROR; end if; else if NON_BLANK_FLAG = TRUE then raise DATA_ERROR; end if; end if; end loop; end CHECK_FOR_BLANKS; begin case FIELD_TYPE is when DATE_TIME_GROUP => begin loop begin GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..2), FIELD_POSITION, 1, 31, '0', COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..2) := FIELD_GOTTEN (3..4); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 2, 0, 23, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (3..4) := DUMMY_STRING (1..2); DUMMY_STRING (1..2) := FIELD_GOTTEN (5..6); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 4, 0, 59, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (5..6) := DUMMY_STRING (1..2); CHECKSUM (FIELD_GOTTEN (1..6), DUMMY_STRING (1..1)); FIELD_GOTTEN (8..8) := DUMMY_STRING (1..1); if FIELD_GOTTEN (8) /= ' ' then GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION + 7); PUT (FIELD_GOTTEN (8..8)); end if; if FIELD_GOTTEN (1) = ' ' then BLANK_FLAG := TRUE; else NON_BLANK_FLAG := TRUE; end if; CHECK_FOR_BLANKS (6); exit; exception when DATA_ERROR => PROMPT ("Must either have complete dtg or all blanks"); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); when ERASE_ERROR => COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); FIELD_GOTTEN (1..8) := " Z "; PUT (" Z "); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); end; end loop; end; -- when LATITUDE => begin loop begin GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..2), FIELD_POSITION, 0, 89, '0', COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..2) := FIELD_GOTTEN (3..4); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 2, 0, 59, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (3..4) := DUMMY_STRING (1..2); DUMMY_STRING (1..1) := FIELD_GOTTEN (5..5); GET_NS (DUMMY_STRING (1..1), FIELD_POSITION + 4, LAST, COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (5..5) := DUMMY_STRING (1..1); CHECKSUM (FIELD_GOTTEN (1..4), DUMMY_STRING (1..1)); FIELD_GOTTEN (6..6) := DUMMY_STRING (1..1); if FIELD_GOTTEN (6) /= ' ' then GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION + 5); PUT (FIELD_GOTTEN (6..6)); end if; if FIELD_GOTTEN (1) = ' ' then BLANK_FLAG := TRUE; else NON_BLANK_FLAG := TRUE; end if; CHECK_FOR_BLANKS (6); exit; exception when DATA_ERROR => PROMPT ("Must either have complete latitude or all blanks"); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; when ERASE_ERROR => COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); FIELD_GOTTEN (1..6) := " "; PUT (" "); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); end; end loop; end; -- when LONGITUDE => begin loop begin GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..3), FIELD_POSITION, 0, 179, '0', COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..2) := FIELD_GOTTEN (4..5); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 3, 0, 59, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (4..5) := DUMMY_STRING (1..2); DUMMY_STRING (1..1) := FIELD_GOTTEN (6..6); GET_EW (DUMMY_STRING (1..1), FIELD_POSITION + 5, LAST, COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (6..6) := DUMMY_STRING (1..1); CHECKSUM (FIELD_GOTTEN (1..5), DUMMY_STRING (1..1)); FIELD_GOTTEN (7..7) := DUMMY_STRING (1..1); if FIELD_GOTTEN (7) /= ' ' then GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION + 6); PUT (FIELD_GOTTEN (7..7)); end if; if FIELD_GOTTEN (1) = ' ' then BLANK_FLAG := TRUE; else NON_BLANK_FLAG := TRUE; end if; CHECK_FOR_BLANKS (7); exit; exception when DATA_ERROR => PROMPT ("Must either have complete longitude or all blanks"); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; when ERASE_ERROR => COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); FIELD_GOTTEN (1..7) := " "; PUT (" "); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); end; end loop; end; -- when others => null; -- end case; end GRF_SUB_4; end SUB_PKG_4; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --subgrf5.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE SUB_PKG_5 -- -- File name : SUBGRF5.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with MINI_LINES_AND_FIELDS; use MINI_LINES_AND_FIELDS; with GENERIC_GET_FIELD_UTILITIES; use GENERIC_GET_FIELD_UTILITIES; package SUB_PKG_5 is -- -- this package is required due to Telesoft size limitations. -- here we instantiate input routines for several enumerated -- types, and define an input routine - grf_sub_1 - which -- stands for Get_Rainform_Subroutine_1 and is called by -- get_Rainform_field. The instantiations are based upon generic -- definitions found in generic_get_field_utilities. -- package ENUM4 is new ENUMERATION_IO (PAD_TYPE); procedure GET_PAD is new GET_X_ENUMERATED_FIELD (ENUMERATED_TYPE => PAD_TYPE, GET_PROC => ENUM4.GET); package ENUM5 is new ENUMERATION_IO (TURBULENCE_TYPE); procedure GET_TURBULENCE is new GET_ENUMERATED_FIELD (ENUMERATED_TYPE => TURBULENCE_TYPE, GET_PROC => ENUM5.GET); package ENUM6 is new ENUMERATION_IO (TYPE_CHANGE_TYPE); procedure GET_CHANGE is new GET_ENUMERATED_FIELD (ENUMERATED_TYPE => TYPE_CHANGE_TYPE, GET_PROC => ENUM6.GET); procedure GRF_SUB_5 (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND); end SUB_PKG_5; package body SUB_PKG_5 is procedure GRF_SUB_5 (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_FLAG : in out BOOLEAN; COMMAND_GOTTEN : in out COMMAND) is LAST : POSITIVE; begin -- case FIELD_TYPE is -- when PAD => GET_PAD (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); -- when TURBULENCE => GET_TURBULENCE (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); -- when TYPE_CHANGE => GET_CHANGE (FIELD_GOTTEN (1..FIELD_LENGTH), FIELD_POSITION, LAST, COMMAND_FLAG, COMMAND_GOTTEN); -- when others => null; -- end case; end GRF_SUB_5; end SUB_PKG_5; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --fgparams.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE FORMAL_GENERIC_PARAMETERS -- -- File name : FGPARAMS -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with MINI_LINES_AND_FIELDS; use MINI_LINES_AND_FIELDS; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with LINKED_LIST_PROCEDURES; use LINKED_LIST_PROCEDURES; with EDITOR_TYPES; use EDITOR_TYPES; -- think this not reqd package FORMAL_GENERIC_PARAMETERS is procedure GET_RAINFORM_FIELD (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_GOTTEN : in out COMMAND; COMMAND_FLAG : in out BOOLEAN); package INT_IO is new INTEGER_IO (INTEGER); end FORMAL_GENERIC_PARAMETERS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --fgparams.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE FORMAL_GENERIC_PARAMETERS -- -- File name : FGPARAMS.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with SUB_PKG_1; use SUB_PKG_1; with SUB_PKG_2; use SUB_PKG_2; with SUB_PKG_3; use SUB_PKG_3; with SUB_PKG_4; use SUB_PKG_4; with SUB_PKG_5; use SUB_PKG_5; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with GENERIC_GET_FIELD_UTILITIES; use GENERIC_GET_FIELD_UTILITIES; with STATIC_GET_FIELD_UTILITIES; use STATIC_GET_FIELD_UTILITIES; package body FORMAL_GENERIC_PARAMETERS is procedure GET_RAINFORM_FIELD (FIELD_TYPE : in SUBSET_OF_RAINFORM_FIELDS; FIELD_GOTTEN : in out STRING; FIELD_POSITION : POSITIVE; FIELD_LENGTH : POSITIVE; COMMAND_GOTTEN : in out COMMAND; COMMAND_FLAG : in out BOOLEAN) is -- BLANKS : STRING (1..69) := (1..69 => ' '); DUMMY_STRING : STRING (1..69) := (1..69 => ' '); BLANK_FLAG : BOOLEAN; NON_BLANK_FLAG : BOOLEAN; -- begin -- beginning body of get_Rainform_field -- COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; case FIELD_TYPE is -- when ALTITUDE_LIMITS => ALTITUDE_LIMITS_BLOCK : declare LOW_LIMIT : INTEGER; LAST : POSITIVE := 1; begin loop begin GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..3), FIELD_POSITION, 0, 999, '0', COMMAND_FLAG, COMMAND_GOTTEN); if FIELD_GOTTEN (1..3) /= " " then STR_INT (FIELD_GOTTEN (1..3), LOW_LIMIT); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION + 4); DUMMY_STRING (1..3) := FIELD_GOTTEN (5..7); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..3), FIELD_POSITION + 4, LOW_LIMIT, 999, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (5..7) := DUMMY_STRING (1..3); INT_IO.GET (FIELD_GOTTEN (5..7), LOW_LIMIT, LAST); else FIELD_GOTTEN (5..7) := " "; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION + 4); PUT (FIELD_GOTTEN (5..7)); end if; exit; exception when DATA_ERROR => PROMPT ("Invalid limits given. Please reenter."); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; when ERASE_ERROR => COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); FIELD_GOTTEN (1..7) := " - "; PUT (" - "); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); end; end loop; end ALTITUDE_LIMITS_BLOCK; -- when COMMENT => READ (FIELD_GOTTEN, FIELD_LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); -- when GRID_POINT => begin loop begin GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..4), FIELD_POSITION, 0, 9999, '0', COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..1) := FIELD_GOTTEN (5..5); GET_CONSTRAINED_CHARACTER (DUMMY_STRING (1..1), FIELD_POSITION + 4, '-', '-', COMMAND_FLAG, COMMAND_GOTTEN, TRUE); FIELD_GOTTEN (5..5) := DUMMY_STRING (1..1); DUMMY_STRING (1..3) := FIELD_GOTTEN (6..8); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..3), FIELD_POSITION + 5, 10, 999, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (6..8) := DUMMY_STRING (1..3); if FIELD_GOTTEN (1..4) = " " and FIELD_GOTTEN (5..8) /= " " then raise DATA_ERROR; elsif FIELD_GOTTEN (5) = '-' and FIELD_GOTTEN (6..8) = " " then raise DATA_ERROR; elsif FIELD_GOTTEN (5) = ' ' and FIELD_GOTTEN (6..8) /= " " then raise DATA_ERROR; end if; exit; exception when DATA_ERROR => PROMPT ("Must either have valid grid point or all blanks"); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); when ERASE_ERROR => COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); FIELD_GOTTEN (1..8) := " "; PUT (" "); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); end; end loop; end; -- when OTHER_ALT => begin loop begin GRF_SUB_2 (FIELD_TYPE, FIELD_GOTTEN (1..2), FIELD_POSITION, 2, COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..3) := FIELD_GOTTEN (3..5); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..3), FIELD_POSITION + 2, 0, 999, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (3..5) := DUMMY_STRING (1..3); if (FIELD_GOTTEN (1..2) /= " " and FIELD_GOTTEN (3..5) = " ") or (FIELD_GOTTEN (1..2) = " " and FIELD_GOTTEN (3..5) /= " ") then raise DATA_ERROR; end if; exit; exception when DATA_ERROR => PROMPT ("Must either have complete altitude or all blanks"); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; when ERASE_ERROR => COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); FIELD_GOTTEN (1..5) := " "; PUT (" "); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); end; end loop; end; -- when PC_OR_TC => begin loop begin GRF_SUB_3 (FIELD_TYPE, FIELD_GOTTEN (1..2), FIELD_POSITION, 2, COMMAND_FLAG, COMMAND_GOTTEN); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION + 3); DUMMY_STRING (1..17) := FIELD_GOTTEN (4..20); if COMMAND_FLAG = FALSE then READ (DUMMY_STRING (1..17), 17, COMMAND_FLAG, COMMAND_GOTTEN); end if; FIELD_GOTTEN (4..20) := DUMMY_STRING (1..17); if (FIELD_GOTTEN (1..2) = " " and FIELD_GOTTEN (4..20) /= BLANKS (1..17)) or (FIELD_GOTTEN (1..2) /= " " and FIELD_GOTTEN (4..20) = BLANKS (1..17)) then raise DATA_ERROR; end if; exit; exception when DATA_ERROR => PROMPT ("Must either have complete crew entry or all blanks"); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); when ERASE_ERROR => COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); FIELD_GOTTEN (1..20) := " - "; PUT (" - "); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); end; end loop; end; -- when FLIGHT_TIME_CATEGORY | MEAN_SEA_LEVEL | MONTH => GRF_SUB_1 (FIELD_TYPE, FIELD_GOTTEN, FIELD_POSITION, FIELD_LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); -- when TYPE_CLOUDS | UNITS => GRF_SUB_2 (FIELD_TYPE, FIELD_GOTTEN, FIELD_POSITION, FIELD_LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); -- when WEATHER | BEARING | DECIMAL_DIGITS | DIGITAL | DIGITAL_BIG | FILLED_DIGITS | FREQUENCY | SCORE | TEMPERATURE | FLT_TIME | WEX_TEMP => GRF_SUB_3 (FIELD_TYPE, FIELD_GOTTEN, FIELD_POSITION, FIELD_LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); -- when DATE_TIME_GROUP | LATITUDE | LONGITUDE => GRF_SUB_4 (FIELD_TYPE, FIELD_GOTTEN, FIELD_POSITION, FIELD_LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); -- when PAD | TURBULENCE | TYPE_CHANGE => GRF_SUB_5 (FIELD_TYPE, FIELD_GOTTEN, FIELD_POSITION, FIELD_LENGTH, COMMAND_FLAG, COMMAND_GOTTEN); when others => null; -- end case; exception when ERASE_ERROR => COMMAND_FLAG := TRUE; COMMAND_GOTTEN := ERASE_FIELD; end GET_RAINFORM_FIELD; end FORMAL_GENERIC_PARAMETERS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --fgp2.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE MORE_FORMAL_GENERIC_PARAMETERS -- -- File name : FGP2.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with MINI_LINES_AND_FIELDS; use MINI_LINES_AND_FIELDS; with LINKED_LIST_PROCEDURES; use LINKED_LIST_PROCEDURES; with EDITOR_TYPES; use EDITOR_TYPES; package MORE_FORMAL_GENERIC_PARAMETERS is -- -- Things (Get_Rainform_field) got too big to put all the formal generic -- parameters in one place so we put the rest of them here. -- package INT_IO is new INTEGER_IO (INTEGER); procedure PACK_RAINFORM_LINE (LINE_TO_PACK : in out LINE_OF_TEXT; LINE_FORMAT : in LINE_DEFINITION); procedure UNPACK_RAINFORM_LINE (LINE_TO_UNPACK : in out LINE_OF_TEXT; LINE_FORMAT : in LINE_DEFINITION); package LINE_NAME_IO is new ENUMERATION_IO (USED_RAINFORM_LINES); package ALL_LINE_NAME_IO is new ENUMERATION_IO (UNCLASSIFIED_RAINFORM_LINES); procedure GET_RAINFORM_LINE_NAME (LINE_NAME : out UNCLASSIFIED_RAINFORM_LINES); procedure RAINFORM_LINE_INSERTION; procedure PARSE_RAINFORM_LINE_TYPE (LINE_TO_PARSE : NODE; LINE_TYPE_FOUND : out UNCLASSIFIED_RAINFORM_LINES); end MORE_FORMAL_GENERIC_PARAMETERS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --fgp2.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE MORE_FORMAL_GENERIC_PARAMETERS -- -- File name : FGP2.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; package body MORE_FORMAL_GENERIC_PARAMETERS is procedure PACK_RAINFORM_LINE (LINE_TO_PACK : in out LINE_OF_TEXT; LINE_FORMAT : in LINE_DEFINITION) is TEMP_LINE : LINE_OF_TEXT; -- working text to hold non-empty fields POINTER : INTEGER range 1..71; -- points to next spot in temp_line FIRST_NON_BLANK : INTEGER range 1..69; --points to 1st /' ' in fld LAST_NON_BLANK : INTEGER range 1..69; -- similar to above NUMBER_NON_BLANK : INTEGER range 0..69; -- number /= ' ' in fld NUMBER_OF_FILLERS : INTEGER range 0..69; --number of spots to blank FIELD_POSITION : NATURAL; LINE_LENGTH : INTEGER; FIELD_LENGTH : NATURAL; LEADING_CONTENT : NATURAL; TRAILING_CONTENT : NATURAL; NUMBER_TO_REWRITE : NATURAL; END_OF_FIELD : NATURAL; BLANK_LINE : STRING (1..69) := (others => ' '); STRING_TO_REWRITE : STRING (1..69); LEAD_STRING : STRING (1..69); TRAIL_STRING : STRING (1..69); begin -- -- if the line has no fields, don't pack it. -- if LINE_FORMAT.NUMBER_OF_FIELDS = 0 then return; end if; -- -- we're going to pack, so put passed line into temp line -- and initialize pointer -- LINE_LENGTH := LINE_FORMAT.COMPONENT (LINE_FORMAT.NUMBER_OF_FIELDS).FIELD_LENGTH + LINE_FORMAT.COMPONENT (LINE_FORMAT.NUMBER_OF_FIELDS).FIELD_POSITION - 1; -- -- any trailing content ? -- declare TEMP_PTR : INTEGER := 0; begin for I in 1..10 loop if (LINE_LENGTH + I) > 69 or else LINE_FORMAT.PROTOTYPE_LINE (LINE_LENGTH + I) = ' ' then TEMP_PTR := I; exit; end if; end loop; LINE_LENGTH := LINE_LENGTH + TEMP_PTR - 1; end; TEMP_LINE := LINE_TO_PACK; POINTER := LINE_FORMAT.COMPONENT (1).FIELD_POSITION; for I in reverse 1..LINE_FORMAT.COMPONENT (1).FIELD_POSITION loop if LINE_FORMAT.PROTOTYPE_LINE (I - 1) /= '/' then POINTER := POINTER - 1; else exit; end if; end loop; -- -- we pack field at a time. first we determine whether the field -- is empty. if so, the field becomes null. if not, we strip off -- leading and trailing blanks. -- for I in 1..LINE_FORMAT.NUMBER_OF_FIELDS loop -- -- for readibility -- FIELD_POSITION := LINE_FORMAT.COMPONENT (I).FIELD_POSITION; FIELD_LENGTH := LINE_FORMAT.COMPONENT (I).FIELD_LENGTH; END_OF_FIELD := FIELD_POSITION + FIELD_LENGTH - 1; -- -- compare to prototype field to see if this field is empty -- -- if LINE_TO_PACK (FIELD_POSITION..END_OF_FIELD) /= LINE_FORMAT.PROTOTYPE_LINE (FIELD_POSITION..END_OF_FIELD) then -- -- non-null field. first strip off leading blanks. -- LEADING_CONTENT := 0; TRAILING_CONTENT := 0; STRING_TO_REWRITE := (1..69 => ' '); LEAD_STRING := (1..69 => ' '); TRAIL_STRING := (1..69 => ' '); for J in 1..10 loop -- 10 is more than enough if LINE_FORMAT.PROTOTYPE_LINE (FIELD_POSITION - J) /= '/' then LEADING_CONTENT := LEADING_CONTENT + 1; else exit; end if; end loop; if LEADING_CONTENT > 0 then LEAD_STRING (1..LEADING_CONTENT) := LINE_FORMAT.PROTOTYPE_LINE (FIELD_POSITION - LEADING_CONTENT..FIELD_POSITION - 1); end if; for J in 1..10 loop if LINE_FORMAT.PROTOTYPE_LINE (END_OF_FIELD + J) /= '/' and (END_OF_FIELD + J) <= LINE_LENGTH then TRAILING_CONTENT := TRAILING_CONTENT + 1; else exit; end if; end loop; if TRAILING_CONTENT > 0 then TRAIL_STRING (1..TRAILING_CONTENT) := LINE_FORMAT.PROTOTYPE_LINE (END_OF_FIELD + 1..END_OF_FIELD + TRAILING_CONTENT); end if; FIRST_NON_BLANK := FIELD_POSITION; LAST_NON_BLANK := END_OF_FIELD; -- for J in 1..FIELD_LENGTH loop -- -- assuming this character is not blank. if it is, exit. -- if not, assume the next is non-blank,and continue loop -- if LINE_TO_PACK (FIELD_POSITION + J - 1) = ' ' then FIRST_NON_BLANK := FIRST_NON_BLANK + 1; else exit; end if; -- end loop; -- -- now strip off trailing blanks. -- for J in reverse 1..FIELD_LENGTH loop -- -- assuming this character is not blank. if it is, exit. -- if not, assume the next is non-blank,and continue loop -- if LINE_TO_PACK (FIELD_POSITION + J - 1) = ' ' then LAST_NON_BLANK := LAST_NON_BLANK - 1; else exit; end if; -- end loop; -- -- let's be sure that first_non_blank <= last_non_blank -- if FIRST_NON_BLANK > LAST_NON_BLANK then PROMPT ("something's wrong in pack"); end if; NUMBER_NON_BLANK := LAST_NON_BLANK - FIRST_NON_BLANK + 1; -- -- now lets put the non-blank substring into temp_line -- NUMBER_TO_REWRITE := 0; if LEADING_CONTENT > 0 then STRING_TO_REWRITE (1..LEADING_CONTENT) := LEAD_STRING (1..LEADING_CONTENT); NUMBER_TO_REWRITE := LEADING_CONTENT; end if; STRING_TO_REWRITE (NUMBER_TO_REWRITE + 1..NUMBER_TO_REWRITE + NUMBER_NON_BLANK) := LINE_TO_PACK (FIRST_NON_BLANK..LAST_NON_BLANK); NUMBER_TO_REWRITE := NUMBER_TO_REWRITE + NUMBER_NON_BLANK; if TRAILING_CONTENT > 0 then STRING_TO_REWRITE (NUMBER_TO_REWRITE + 1..NUMBER_TO_REWRITE + TRAILING_CONTENT) := TRAIL_STRING (1..TRAILING_CONTENT); NUMBER_TO_REWRITE := NUMBER_TO_REWRITE + TRAILING_CONTENT; end if; TEMP_LINE (POINTER..POINTER + NUMBER_TO_REWRITE) := STRING_TO_REWRITE (1..NUMBER_TO_REWRITE) & "/"; -- -- finally we update pointer -- POINTER := POINTER + NUMBER_TO_REWRITE + 1; -- else -- -- here the field was null, so just add a '/' -- TEMP_LINE (POINTER) := '/'; POINTER := POINTER + 1; -- end if; end loop; -- -- strip off any trailing /'s -- while TEMP_LINE (POINTER - 1) = '/' loop TEMP_LINE (POINTER - 1) := ' '; POINTER := POINTER - 1; end loop; -- if POINTER <= 69 then NUMBER_OF_FILLERS := 69 - POINTER + 1; TEMP_LINE (POINTER..69) := BLANK_LINE (1..NUMBER_OF_FILLERS); end if; -- -- replace line_to_pack with temp_line -- LINE_TO_PACK := TEMP_LINE; -- end PACK_RAINFORM_LINE; -- procedure UNPACK_RAINFORM_LINE (LINE_TO_UNPACK : in out LINE_OF_TEXT; LINE_FORMAT : in LINE_DEFINITION) is TEMP_LINE : LINE_OF_TEXT := (1..80 => ' '); -- working text POINTER : INTEGER range 1..71; --points to next spot in ln_to_upk FIRST_NON_BLANK : INTEGER range 1..69; --points to 1st /' ' in fld LAST_NON_BLANK : INTEGER range 1..69; -- similar to above NUMBER_NON_BLANK : INTEGER range 0..69; -- number /= ' ' in fld NUMBER_BLANK : INTEGER; -- number = ' ' to left pad NUMBER_OF_FILLERS : INTEGER range 0..69; --number of spots to blank FIELD_POSITION : NATURAL; STR : STRING (1..1); LEADING_CONTENT : NATURAL := 0; TRAILING_CONTENT : NATURAL := 0; LINE_LENGTH : NATURAL; FIELD_LENGTH : NATURAL; END_OF_FIELD : NATURAL; BLANK_LINE : STRING (1..69) := (others => ' '); TEMP_NON_BLANK : POSITIVE; LOOP_LENGTH : POSITIVE; begin -- if LINE_FORMAT.NUMBER_OF_FIELDS = 0 then return; end if; -- -- we're going to unpack. -- initialize pointer to the first possible character, -- and we initialize temp_line to the prototype line. -- LINE_LENGTH := LINE_FORMAT.COMPONENT (LINE_FORMAT.NUMBER_OF_FIELDS).FIELD_LENGTH + LINE_FORMAT.COMPONENT (LINE_FORMAT.NUMBER_OF_FIELDS).FIELD_POSITION - 1; -- -- any trailing content ? -- declare TEMP_PTR : INTEGER := 0; begin for I in 1..10 loop if (LINE_LENGTH + I) > 69 or else LINE_FORMAT.PROTOTYPE_LINE (LINE_LENGTH + I) = ' ' then TEMP_PTR := I; exit; end if; end loop; LINE_LENGTH := LINE_LENGTH + TEMP_PTR - 1; end; TEMP_LINE (1..LINE_LENGTH) := LINE_FORMAT.PROTOTYPE_LINE (1..LINE_LENGTH); TEMP_NON_BLANK := LINE_LENGTH; for I in reverse 1..LINE_LENGTH loop if LINE_TO_UNPACK (I) /= ' ' then TEMP_NON_BLANK := I; exit; end if; end loop; LINE_TO_UNPACK (TEMP_NON_BLANK + 1..TEMP_NON_BLANK + 2) := "/ "; for I in 1..LINE_LENGTH loop if LINE_TO_UNPACK (I) = '/' then POINTER := I + 1; exit; end if; end loop; -- -- we unpack field at a time. first we determine whether the field -- is null. if so, the field is filled with blanks. if not, we -- place the characters right-justified into the field. -- for I in 1..LINE_FORMAT.NUMBER_OF_FIELDS + 1 loop -- -- see if field is null or if we are at the end of the line -- if LINE_TO_UNPACK (POINTER) = '/' then -- -- null field so leave temp_line as prototype -- POINTER := POINTER + 1; -- elsif LINE_TO_UNPACK (POINTER) = ' ' then -- -- we're done with this line so exit loop -- exit; -- else -- -- there's something here, so isolate it, pad on the -- left with blanks, and put it in temp_line. -- to do this, initialize first & last non-blank to -- first non blank character. then increment pointer -- and update last_non_blank as appropriate while looping -- through the field -- -- -- for readibility -- FIELD_POSITION := LINE_FORMAT.COMPONENT (I).FIELD_POSITION; FIELD_LENGTH := LINE_FORMAT.COMPONENT (I).FIELD_LENGTH; END_OF_FIELD := FIELD_POSITION + FIELD_LENGTH - 1; LEADING_CONTENT := 0; TRAILING_CONTENT := 0; for J in 1..10 loop -- 10 is more than enough if LINE_FORMAT.PROTOTYPE_LINE (FIELD_POSITION - J) /= '/' then LEADING_CONTENT := LEADING_CONTENT + 1; else exit; end if; end loop; for J in 1..10 loop if LINE_FORMAT.PROTOTYPE_LINE (END_OF_FIELD + J) /= '/' and (END_OF_FIELD + J) < LINE_LENGTH then TRAILING_CONTENT := TRAILING_CONTENT + 1; else exit; end if; end loop; FIRST_NON_BLANK := POINTER; -- -- isolate the last character of the field -- LOOP_LENGTH := FIRST_NON_BLANK + FIELD_LENGTH + LEADING_CONTENT + TRAILING_CONTENT; if LINE_TO_UNPACK (1..5) = "ASSOC" then for J in reverse 7..69 loop if LINE_TO_UNPACK (J) /= ' ' then LAST_NON_BLANK := J; POINTER := J + 1; exit; end if; end loop; else for J in FIRST_NON_BLANK..LOOP_LENGTH loop if J = LOOP_LENGTH or else LINE_TO_UNPACK (J) = '/' then LAST_NON_BLANK := J - 1; POINTER := J + 1; exit; end if; end loop; end if; -- -- compute number of non_blanks and left pad -- NUMBER_NON_BLANK := LAST_NON_BLANK - FIRST_NON_BLANK - LEADING_CONTENT - TRAILING_CONTENT + 1; NUMBER_BLANK := FIELD_LENGTH - NUMBER_NON_BLANK; TEMP_LINE (FIELD_POSITION..END_OF_FIELD) := LINE_TO_UNPACK (FIRST_NON_BLANK + LEADING_CONTENT..LAST_NON_BLANK - TRAILING_CONTENT) & BLANK_LINE (1..NUMBER_BLANK); end if; end loop; -- -- replace line_to_pack with temp_line -- LINE_TO_UNPACK (1..LINE_LENGTH) := TEMP_LINE (1..LINE_LENGTH); if LINE_LENGTH < 69 then LINE_TO_UNPACK (LINE_LENGTH + 1..69) := BLANK_LINE (LINE_LENGTH + 1..69); end if; -- exception when CONSTRAINT_ERROR => PROMPT ("Constraint error in unpack"); end UNPACK_RAINFORM_LINE; procedure GET_RAINFORM_LINE_NAME (LINE_NAME : out UNCLASSIFIED_RAINFORM_LINES) is DUMMY_STRING : STRING (1..8); CHARACTERS_GOTTEN : POSITIVE; COMMAND_FLAG : BOOLEAN; COMMAND_GOTTEN : COMMAND; begin loop begin READ (DUMMY_STRING, 8, COMMAND_FLAG, COMMAND_GOTTEN); LINE_NAME_IO.GET (DUMMY_STRING, LINE_NAME, CHARACTERS_GOTTEN); exit; exception when END_ERROR => exit; when others => PROMPT ("Invalid line name entry. Please reenter data."); GOTO_CRT_POSITION (TOP_OF_AMP_AREA + 4, 70); end; end loop; end GET_RAINFORM_LINE_NAME; procedure RAINFORM_LINE_INSERTION is begin null; end RAINFORM_LINE_INSERTION; procedure PARSE_RAINFORM_LINE_TYPE (LINE_TO_PARSE : NODE; LINE_TYPE_FOUND : out UNCLASSIFIED_RAINFORM_LINES) is TEMP_LINE_TYPE : UNCLASSIFIED_RAINFORM_LINES; NUMBER_OF_CHARACTERS : INTEGER range 3..10; N_CHAR : POSITIVE; begin -- -- we proceed from head to tail of the message in wd, and -- for each line, we deterime the line type from the first 3-5 -- characters of the line of text -- we then determine the position of that line type in the type -- Rainform_lines, and store the position in the line_type -- field of the message component. -- GET_BLOCK : begin ALL_LINE_NAME_IO.GET (LINE_TO_PARSE.TEXT_LINE, TEMP_LINE_TYPE, N_CHAR); exception when DATA_ERROR => TEMP_LINE_TYPE := FREE; PROMPT ("illegal linetype found - set to freeform"); end GET_BLOCK; if TEMP_LINE_TYPE = FREE then LINE_TYPE_FOUND := FREE; return; end if; -- -- in certain cases, one line type is a prefix of another. check -- to determine which type we have here. -- for I in reverse 1..69 loop if LINE_TO_PARSE.TEXT_LINE (I) /= ' ' then N_CHAR := I; exit; end if; end loop; case TEMP_LINE_TYPE is -- when AREA => if N_CHAR <= 5 then TEMP_LINE_TYPE := AREA_LL; elsif LINE_TO_PARSE.TEXT_LINE (6) = 'A' then TEMP_LINE_TYPE := AREA_A; elsif LINE_TO_PARSE.TEXT_LINE (N_CHAR - 1..N_CHAR) = "NM" then TEMP_LINE_TYPE := AREA_C; else TEMP_LINE_TYPE := AREA_LL; end if; when ELLIP => if LINE_TO_PARSE.TEXT_LINE (N_CHAR - 3..N_CHAR) = "SQNM" then TEMP_LINE_TYPE := ELLIP_A; else TEMP_LINE_TYPE := ELLIP_R; end if; when ROUTE => if N_CHAR <= 6 then TEMP_LINE_TYPE := ROUTE_LL; elsif LINE_TO_PARSE.TEXT_LINE (7) = 'P' then -- -- first find next '/' then see if there is -- a "P-" following. -- TEMP_LINE_TYPE := ROUTE_PL; OUTER : for I in 7..N_CHAR loop if LINE_TO_PARSE.TEXT_LINE (I) = '/' then INNER : for J in I..N_CHAR loop if LINE_TO_PARSE.TEXT_LINE (J..J + 1) = "P-" then TEMP_LINE_TYPE := ROUTE_PP; exit OUTER; end if; end loop INNER; end if; end loop OUTER; else -- -- its a route_lx. fill in the x -- TEMP_LINE_TYPE := ROUTE_LL; INNER2 : for I in 7..N_CHAR loop if LINE_TO_PARSE.TEXT_LINE (I..I + 1) = "P-" then TEMP_LINE_TYPE := ROUTE_LP; exit; end if; end loop INNER2; end if; when TRACK => if N_CHAR >= 7 and LINE_TO_PARSE.TEXT_LINE (7) = 'T' then TEMP_LINE_TYPE := TRACK_N; else TEMP_LINE_TYPE := TRACK_LL; end if; when others => null; -- end case; LINE_TYPE_FOUND := TEMP_LINE_TYPE; end PARSE_RAINFORM_LINE_TYPE; end MORE_FORMAL_GENERIC_PARAMETERS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --rfeditor.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE RF_EDITOR -- -- File name : RFEDITOR.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with MINI_LINES_AND_FIELDS; use MINI_LINES_AND_FIELDS; with FILE_GENERIC; use FILE_GENERIC; with FORMAL_GENERIC_PARAMETERS; use FORMAL_GENERIC_PARAMETERS; with MORE_FORMAL_GENERIC_PARAMETERS; use MORE_FORMAL_GENERIC_PARAMETERS; with LINKED_LIST_PROCEDURES; use LINKED_LIST_PROCEDURES; with CLASSIFICATION_DEFINITION; use CLASSIFICATION_DEFINITION; -- package RF_EDITOR is package RAINFORM_ED is new FILE_GENERIC.FILED_GENERIC_MESSAGE_EDITOR (MAXIMUM_FIELDS_PER_LINE => 17, MAXIMUM_CHARACTERS_PER_LINE => 69, MAXIMUM_LINES_PER_MESSAGE => 100, LINE_NAME => UNCLASSIFIED_RAINFORM_LINES, GET_LINE_NAME => GET_RAINFORM_LINE_NAME, FIELD_NAME => SUBSET_OF_RAINFORM_FIELDS, LINE_STRUCTURE_FILE_NAME => "RAINFORM.DES", FIELD_PROMPT_FILE_NAME => "RNPROMPT.DES", PROMPT_VECTOR_FILE_NAME => "RAINLUT.DES", GET_FIELD => GET_RAINFORM_FIELD, PACK_LINE => PACK_RAINFORM_LINE, UNPACK_LINE => UNPACK_RAINFORM_LINE, VALIDATE_LINE_INSERTION => RAINFORM_LINE_INSERTION, PARSE_LINE_TYPE => PARSE_RAINFORM_LINE_TYPE); -- -- end RF_EDITOR; -- package body RF_EDITOR is -- end RF_EDITOR; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --urlnsflds.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE UNITREP_LINES_AND_FIELDS -- -- File name : URLNSFLDS.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- package UNITREP_LINES_AND_FIELDS is -- -- FIRST, define the line types used in Unitrep messages -- type UNITREP_LINE_NAMES is (A, B, C, D, G, J, K, L, M, N, P, Q, T, V, X, R, DM1, DN1, JM1, KF1, KF2, KF3, KF4, KN1, RM3, TF1, H, E, NIL); -- -- ALSO, define values for the number of lines, number of characters -- per line, and number of fields per line -- UNITREP_MAXIMUM_FIELDS_PER_LINE : POSITIVE := 34; -- UNITREP_MAXIMUM_CHARACTERS_PER_LINE : POSITIVE := 80; -- UNITREP_MAXIMUM_LINES_PER_MESSAGE : POSITIVE := 75; -- -- NEXT, define the names of the fields for Unitrep messages -- type UNITREP_FIELD_NAMES is (CARD_NUMBER, CLASSIFICATION, UAC, RECORD_ID, UIC, ORIGINATORS_UIC, MESSAGE_TYPE, MESSAGE_NUMBER, UDC, ANAME, UTC, ULC, MJCOM, MAJOR, REVAL, TPSN, SCLAS, LNAME, COAFF, MONOR, CSERV, OPCON, ADCON, HOGEO, PRGEO, EMBRK, ACTIV, FLAG, PUIC, CBCOM, DFCON, POINT, NUCIN, PCTEF, BILET, CORNK, CONAM, MMCMD, NTASK, MODFG, PLETD, NDEST, DETA, CXMRS, TCAA, MEDIA, TADC, ROUTE, RWDTE, XRTE, XDATE, TPERS, PEGEO, STRUC, AUTH, ASGD, POSTR, PICDA, DEPS, TDEPS, CASPW, CCASP, CCEBY, SCATD, MGO, AGO, NA, NFO, MENL, NAVO, NAVE, OTHOF, OTHEN, PIAOD, TREAD, READY, REASN, PRRAT, PRRES, ESRAT, ESRES, ERRAT, ERRES, TRRAT, TRRES, SECRN, TERRN, CARAT, CADAT, LIM, RLIM, RICDA, DOCNR, DOCID, PERTP, TPAUT, TPASG, TPAVL, PERTC, CPAUR, CPASG, CPAVL, TRUTC, TMTHD, TCARQ, TCRAS, TCRAV, TRSA1, TRSA2, TRSA3, TRSA4, TRSA5, EQSEE, EQSSE, MEARD, MEASG, MEPOS, ESSA1, ESSA2, ESSA3, ESSA4, ESSA5, ESSA6, ESSA7, ESSA8, ESSA9, EQREE, EQRED, MEMRA, ERSA1, ERSA2, ERSA3, ERSA4, ERSA5, ERSA6, ERSA7, ERSA8, SDOC, READF, REASF, PRRAF, PRREF, ESRAF, ESREF, ERRAF, ERREF, TRRAF, TRREF, SECRF, TERRF, CARAF, CADAF, LIMF, RLIMF, RICDF, RESPF, SMCC1, SMRA1, SMAA1, SMRC1, SMAC1, SMCC2, SMRA2, SMAA2, SMRC2, SMAC2, SMCC3, SMRA3, SMAA3, SMRC3, SMAC3, SMCC4, SMRA4, SMAA4, SMRC4, SMAC4, GCCLA, GCCLB, GCCLC, SPCLU, PRMA, MARAT, MAREA, CHDAT, FMART, FCDAT, MEQPT, FORDV, MEPSA, METAL, MEPSD, MEORD, MEORN, MEORC, MEORO, CREWA, CREAL, CREWF, CRMRD, CRMRN, CRMRC, CRMRO, MEREC, TEGEO, PIN, FRQNO, PLEAC, DDP, DDPRD, MDT, PUTCV, PEQPT, TPGEO, ALTYP, NUMBR, NUMEA, ALRET, NUSEQ, WPNCO, NUQPT, DSGEO, NUMWR, NUMWB, NUGUN, RTIME, DSSTA, RFGDS, NUSTO, NUECC, SEQ, TOT, LABEL, RMKID, REMRK, TEQPT, MESEN, DECON, MECUS, AVCAT, RESND, ERDTE, EXDAC, CPGEO, CFGEO, EQDEP, EQARR, TPIN, TLEAC, TLEQE, UEQPT, MEQS, SEDY, TEDY, ERRDY, AVAIL, DCNDY, EQRET, GEOGR, OPERL, DAFLD, ACGEO, ACITY, ADATE, MDATE, RDATE, GCMD, TDATE, TRGEO, DEPDT, ARRDT, RPTOR, INTR1, INTR2, SBRPT, ATACH, NOT_USED, H_CARD_NUMBER, DAY_OF_MONTH, MONTH, YEAR, REAL_OR_EXERCISE, NIL ); -- ------------------------------------------------------------------- -- -- Turns out need subtypes for the get_field case statement under -- the TeleSoft compiler -- subtype STANDARD_NAMES is UNITREP_FIELD_NAMES range CARD_NUMBER..MESSAGE_NUMBER; -- subtype ABC_NAMES is UNITREP_FIELD_NAMES range UDC..MONOR; -- subtype DGJ_NAMES is UNITREP_FIELD_NAMES range CSERV..PIAOD; -- subtype K_NAMES is UNITREP_FIELD_NAMES range TREAD..FCDAT; -- subtype LM_NAMES is UNITREP_FIELD_NAMES range MEQPT..TEGEO; -- subtype NPQ_NAMES is UNITREP_FIELD_NAMES range PIN..NUECC; -- subtype RTV_NAMES is UNITREP_FIELD_NAMES range SEQ..RDATE; -- subtype XEH_NAMES is UNITREP_FIELD_NAMES range GCMD..REAL_OR_EXERCISE; -- end UNITREP_LINES_AND_FIELDS; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --urfldtyps.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE UNITREP_FIELD_TYPES -- -- File name : URFLDTYPS.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- package Unitrep_field_types is -- -- DEFINE the field types associated with the field names -- -------------------------------------------------------------- -- these are the common field types used in Unitrep -------------------------------------------------------------- subtype Card_number_type is integer range 0..999; type Classification_type is ( U,C,S,T ); type UAC_type is ( A,C,D,R ); subtype Record_id_type is string ( 1..3 ); -- the 3 character string of line_names type UIC_type is ( DDAAAA,DEAAAA,DJJ010,DJ1000, DJ1200,DJ2000,DJ3000,DJ3020,DJ3021, DJ3023,DJ3024,DJ3025,DJ3026,DJ3090, DJ4000,DJ5000,DJ6000,DJ7000,DJ8000, DJ9000,DLAAAA,DMAAAA,W0ZUFF,W00QAA, W00YFF,W38BFF,W38AFF,W3VYFF,W3YBFF,WATMFF, W0ALFF,W0ANFF,W0ATFF,W32FFF,W0GTAA,W0GVAA, W0GWFF,W0QFAA,WATGFF,W4NHFF,N00011,N00033, N00060,N00061,N00070,N00072,N00071,FFQT10, FFB370,FFB790,FFBBB0,FFBCC0,FFBSD0, FFC4D0,FFCL80,FFCLM0,FFCMF0,FFCMJ0,FFCRS0, FFFHL0,FFFTC0,FFGKT0,FFGTW0,FFH5M0, FFH7B0,FFH7BA,FFH7BB,FFHCS0,FFJQ20, FFVGB0,M54000,M00400,M14000,M20000, M20020,E70098,E73130,E75120,E75150,XXAAAA, ZZZDAA,ZZZDAB,ZZZDAC,ZZZDAD,ZZZDAE,ZZZDAF, ZZZDAG,ZZZDAH,ZZZDAJ ); subtype Originators_UIC_type is UIC_type; subtype Message_type_type is string ( 1..2 ); subtype Message_number_type is integer range 0..999; -- day/month/year formats type DDDYY_type is record ddd : integer range 1..366; yy : integer range 0..99; end record; type YYMMDD_type is record yy : integer range 0..99; mm : integer range 1..12; dd : integer range 1..31; end record; type YYMMDDHH_type is record yy : integer range 0..99; mm : integer range 1..12; dd : integer range 1..31; hh : integer range 0..24; end record; type DDDHH_type is record ddd : integer range 1..366; hh : integer range 0..24; end record; type HHHMM_type is record hhh : integer range 0..999; mm : integer range 0..59; end record; type MMDDHH_type is record year : integer; mm : integer range 1..12; dd : integer range 1..31; hh : integer range 0..24; end record; -------------------------------------------------------------- -- Unitrep field types for A, B, C -------------------------------------------------------------- type UDC_type is ( A,B,C,D,E,F,T,U,V,W,X,Y,Z, G,H,L,N,J,K,P,Q,R,S ); -- special check for 1,3,5,7,9,2,4,6,8,0 is necessary subtype ANAME_type is string ( 1..30 ); subtype UTC_type is string ( 1..5 ); type ULC_type is ( A ,ACD,ACT,ADM,AF ,AFY,AGP,AGY,ANX, AP ,AR ,ARS,AST,AUG,B ,BAS,BD ,BDE, BKS,BLT,BN ,BND,BR ,BSN,BT ,BTY,CAY, CEC,CEP,CGC,CGE,CLN,CMD,CMN,CMP,CO , CPS,CRW,CTP,CTR,DAY,DEP,DET,DIR,DIV, DMB,DMF,DML,DMM,DMP,DMR,DMT,DMU,DSP, DST,DTL,ELE,FAC,FAR,FLO,FLT,FMF,FTR, FT ,GAR,GRP,HBD,HHB,HHC,HHD,HHS,HHT, HM ,HMC,HQ ,HQC,HQD,HQS,HSB,HSC,HSP, INS,ISP,IST,LAB,LIB,MAA,MAB,MAF,MAG, MAU,MAW,MER,MGR,MGZ,MIS,MSC,MSF,MTF, MUS,NSC,NSL,OBS,OFC,OFF,OIC,OL , PKG,PKT,PLN,PLT,PO ,PRT,PTY,PVG,RCT, REP,RES,RGN,RGT,RLT,RNG,SCH,SCM,SCO, SCT,SEC,SHP,SIP,SQ ,SQD,SS ,SST,STA, STF,STP,STR,SU ,SUP,SVC,SYD,SYS,TE , TF ,TG ,TM ,TML,TRN,TRP,TU ,U ,USS, WG ,WKS ); -- special check for FOR is required subtype MJCOM_type is string ( 1..6 ); type MAJOR_type is ( X ); type REVAL_type is ( G,R,X ); subtype TPSN_type is string ( 1..7 ); type SCLAS_type is ( U,C,S,T ); ------------------------- B -------------------------------- subtype LNAME_type is string ( 1..55 ); ------------------------- C -------------------------------- type COAFF_type is ( AC, AF, AG, AL, AN, AO, AQ, AR, AS, AU, AV, AY, BA, BB, BC, BD, BE, BF, BG, BH ,BL, BM, BP, BQ, BR, BT, BU, BV, BX, BY, BZ, CA, CB, CD, CE, CF, CG, CH, CI, CJ, CK, CL, CM, CN, CO, CQ, CS, CT, CU, CV, CW, CY, CZ, DA, DJ, DM, DR, EC, EG, EI, EK, EQ, ES, ET, FA, FG, FI, FJ, FO, FP, FR, FS, FT, GA, GB, GC, GE, GH, GI, GJ, GL, GP, GQ, GR, GT, GV, GY, GZ, HA, HK, HM, HO, HU, IC, ID, IO, IQ, IR, IT, IV, IY, IZ, JA, JM, JO, JQ, JS, KE, KN, KR, KS, KT, KU, LA, LE, LI, LS, LT, LU, LY, MA, MB, MC, MG, MH, MI, ML, MN, MO, MP, MQ, MR, MT, MU, MV, MX, MY, MZ, NA, NC, NE, NF, NG, NH, NI, NL, NO, NP, NQ, NR, NS, NU, NZ, PA, PC, PE, PF, PG, PK, PL, PM, PO, PP, PQ, PU, QA, RE, RO, RP, RQ, RW, SA, SB, SC, SE, SF, SG, SH, SL, SM, SN, SO, SP, SQ, ST, SU, SW, SY, SZ, TC, TD, TH, TK, TL, TN, TO, TP, TQ, TS, TU, TV, TW, TZ, UG, UK, UN, UR, US, UV, UY, VC, VE, VI, VM, VQ, VT, WA, WF, WI, WQ, WS, WZ, YE, YO, YS, ZA, ZI ); -- special check for DO, IN, IS required subtype MONOR_type is string ( 1..6 ); -------------------------------------------------------------- -- Unitrep field types for D -------------------------------------------------------------- type CSERV_type is ( C,D,A,N,F,M,E,J ); -- special check for 1,2,3,4,5,6,7,8,9 subtype OPCON_type is string ( 1..6 ); subtype ADCON_type is string ( 1..6 ); subtype HOGEO_type is string ( 1..4 ); subtype PRGEO_type is string ( 1..4 ); subtype EMBRK_type is string ( 1..6 ); type ACTIV_type is ( AC,CW,DE,ED,ER,NP,PD,PH,PK,PL,PS, RD,UM,UN,XX,AN,AS,CA,CD,CJ,CM,CS, DA,DR,FP,FR,GF,IP,LD,LE,ON,OP, PC,PM,PO,PA,PV,PW,RC,RE,RF,RO,RR, SM,SR,CR,CV,MA,OH,RA,RX,DS,FO,OE, OT,SD,TE,TO,BT,NA,RT,TA,TB,TR,TS, TU,TW,AD,AU,EX,GW,MR ); -- special check for IN required type FLAG_type is ( X ); subtype PUIC_type is UIC_type; type CBCOM_type is ( A,B,E,K,N,P,T ); type DFCON_type is ( N,T,V,S,R,G ); -- special check for 5,4,3,2,1 subtype POINT_type is string ( 1..15 ); type NUCIN_type is ( X ); subtype PCTEF_type is string ( 1..1 ); ------------------------- DM1 ------------------------------ type BILET_type is ( CG, CO, OIC, NCO ); type CORNK_type is ( SGT, LT, CAPT, MAJ, LTCOL, COL, GEN ); subtype CONAM_type is string ( 1..17 ); type MMCMD_type is ( M00048,M00049,M00051,M00053,M00055,M00070, M00074,M00101,M00201,M00300,M00400,M00407, M01333,M01369,M01531,M11000,M12000,M13000, M14000,M18032,M18045,M18172,M19001,M19009, M19012,M19015,M19033,M19100,M19137,M19500, M20000,M20020,M20040,M20051,M20080,M20128, M20135,M20146,M21580,M21610,M27100,M28300, M29000,M54000,M61610,M96300 ); -- MAJOR MARINE COMMAND -- SPECIAL CHECK FOR Mmcmd_Types "# " ------------------------- DN1 ------------------------------ subtype NTASK_type is string ( 1..13 ); subtype MODFG_type is string ( 1..1 ); subtype PLETD_type is MMDDHH_type; subtype NDEST_type is string ( 1..11 ); subtype DETA_type is MMDDHH_type; subtype CXMRS_type is string ( 1..1 ); -------------------------------------------------------------- -- Unitrep field types for E -------------------------------------------------------------- subtype Not_Used_type is string ( 1..2 ); -------------------------------------------------------------- -- Unitrep field types for G -------------------------------------------------------------- subtype TCAA_type is string ( 1..29 ); type MEDIA_type is ( C,L,M,T ); type TADC_type is ( X ); subtype ROUTE_type is string ( 1..7 ); subtype RWDTE_type is DDDYY_type; subtype XRTE_type is string ( 1..7 ); subtype XDATE_type is DDDYY_type; -------------------------------------------------------------- -- Unitrep field types for H -------------------------------------------------------------- subtype H_card_number_type is integer range 0..9; subtype Day_of_month_type is integer range 1..31; type Month_type is ( JAN,FEB,MAR,APR,MAY,JUN, JUL,AUG,SEP,OCT,NOV,DEC ); subtype Year_type is integer range 0..99; type Real_or_Exercise_type is ( R,X ); -------------------------------------------------------------- -- Unitrep field types for J -------------------------------------------------------------- type TPERS_type is (CS,CQ,CP,AC,NC,MC,FC,EC,AW,NW,MW, FW,EW,AE,NE,ME,FE,EE,ZA,ZE,ZC,RC, RE,RW,AK,NK,MK,FK,EK,AX,NX,MX,FX, EX,NT,MT,FT,ET,AM,NM,MM,FM,EM,AI, NI,MI,FI,EI,AD,ND,MD,FD,ED,AH,NH, MH,FH,EH,AL,NL,ML,FL,EL,ZZ); -- SPECIAL CHECK FOR Tpers_Types "AT" subtype PEGEO_type is string ( 1..6 ); subtype STRUC_type is string ( 1..5 ); subtype AUTH_type is string ( 1..5 ); subtype ASGD_type is string ( 1..5 ); subtype POSTR_type is string ( 1..5 ); subtype PICDA_type is YYMMDD_type; subtype DEPS_type is string ( 1..5 ); subtype TDEPS_type is string ( 1..5 ); subtype CASPW_type is string ( 1..5 ); subtype CCASP_type is string ( 1..5 ); type CCEBY_type is ( X ); ------------------------- JM1 ------------------------------ type SCATD_type is ( TO ); subtype MGO_type is string ( 1..5 ); subtype AGO_type is string ( 1..5 ); subtype NA_type is string ( 1..5 ); subtype NFO_type is string ( 1..5 ); subtype MENL_type is string ( 1..5 ); subtype NAVO_type is string ( 1..5 ); subtype NAVE_type is string ( 1..5 ); subtype OTHOF_type is string ( 1..5 ); subtype OTHEN_type is string ( 1..5 ); subtype PIAOD_type is string ( 1..6 ); -------------------------------------------------------------- -- Unitrep field types for K -------------------------------------------------------------- -- --- special enumerated type used for a number of K card fields -- type PRIMARY_REASON is ( P01,P02,P03,P04,P05,P06,P07,P08,P09, P10,P11,P12,P13,P14,P15,P16,P17,P18, P19,P20,P21,P22,P23,P24,P25,P26,P27, P28,P29,P30,P31,P32,P33,P34,P35,P36, P37,P38,P39,P40,P41,P42,P43,P44,P45, P46,P47,P48,P49,P50,P51,P52,P53,P54, P55,P56,P57,P58,P59,P60,P61,P62,P63, P64,P65,P66,P67,P68,P69,P70,P71,P72, P73,P74,P75,P76,P77,P78,P79,P80,PUP, S01,S02,S03,S04,S05,S06,S07,S08,S09, S10,S11,S12,S13,S14,S15,S16,S17,S18, S19,S20,S21,S22,S23,S24,S25,S26,S27, S28,S29,S30,S31,S32,S33,S34,S35,S36, S37,S38,S39,S40,S41,S42,S43,S44,S45, S46,S47,S48,S49,S50,S51,S52,S53,S54, S55,S56,S57,S58,S59,S60,S61,S62,S63, S64,S65,S66,S67,S68,S69,S70,S71,S72, S73,S74,S75,S76,S77,S78,S79,S80,S81, S82,S83,S84,S85,S86,S87,S88,S89,S90, S91,S92,S93,S94,S95,S96,S97,S98,SUP, R00,R01,R02,R03,R04,R05,R06,R07,R08, R09,R10,R11,R12,R13,R14,R15,R16,R17, R18,R19,R20,R21,R22,R23,R24,R25,R26, R27,R28,R29,R30,R31,R32,R33,R34,R35, R36,R37,R38,R39,R40,R41,R42,R43,R44, R45,R46,R47,R48,R49,R50,R51,R52,R53, R54,R55,R56,R57,R58,R59,R60,R61,R62, R63,R64,R65,R66,R67,R68,R69,R70,R71, R72,R73,R74,R75,R76,R77,R78,R79,R80, R81,R82,R83,R84,R85,R86,R87,R88,R89, R90,R91,R92,R93,R94,R95,R96,R97,R98, R99,RAA,RAB,RAC,RAD,RAE,RAF,RAG,RAH, RAL,RAN,RAP,RAQ,RAR,RAS,RAT,RAU,RAV, RAW,RAX,RAY,RBA,RBB,RBC,RBD,RBE,RBF, RBG,RBH,RBI,RBJ,RBK,RBL,RBM,RBN,RUP, T01,T02,T03,T04,T05,T06,T07,T08,T09, T10,T11,T12,T13,T14,T15,T16,T17,T18, T19,T20,T21,T22,T23,T24,T25,T26,T27, T28,T29,T30,T31,T32,T33,T34,T35,T36, T37,T38,T39,T40,T41,T42,T43,T44,T45, T46,T47,T48,T49,T50,T51,T52,T53,T54, T55,T56,T57,T58,T59,T60,T61,T62,T63, T64,T65,T66,T67,T68,T69,T70,T71,T72, T73,T74,T75,T76,T77,T78,T79,T80,T81, T82,T83,TUP); -------------------------------------------------------------- type TREAD_type is ( JCRR1,POMCS ); subtype READY_type is string ( 1..1 ); type REASN_type is ( P,S,R,T,M,N,X ); subtype PRRAT_type is string ( 1..1 ); subtype PRRES_type is PRIMARY_REASON range P01..P80; subtype ESRAT_type is string ( 1..1 ); subtype ESRES_type is PRIMARY_REASON range S01..S98; subtype ERRAT_type is string ( 1..1 ); subtype ERRES_type is PRIMARY_REASON range R00..RBN; subtype TRRAT_type is string ( 1..1 ); subtype TRRES_type is PRIMARY_REASON range T01..T83; subtype SECRN_type is string ( 1..3 ); subtype TERRN_type is string ( 1..3 ); subtype CARAT_type is string ( 1..1 ); subtype CADAT_type is YYMMDD_type; subtype LIM_type is string ( 1..1 ); type RLIM_type is ( P,S,R,T ); subtype RICDA_type is YYMMDD_type; ------------------------- KF1 ------------------------------ subtype DOCNR_type is string ( 1..1 ); type DOCID_type is ( AM22,AG23,AM24,BM22,BG23,BM24,BG25,CM22, CG23,CM24,CG25,CD26,CM28,CM29,DM22,DG23, DM24,DG25,DM26,DG27,DM28,DG29,DM32,DG33, DM34,DG35,DG36,DG37,EM22,EG23,EM24,EG25, EM26,EG27,FM22,FG23,FD24,FM25,FG26,FM27, FG28,FM29,FG33,FM34,FG35,FM36,FG37,FD38, GM22,GG23,HM22,HG23,HM24,HG25,HM26,HG27, JM22,JG23,JM24,JG25,JM26,JG27,KM22,KG23, LM22,LG23,LM24,LG25,LM26,LG27,LM28,LG29, MM22,MG23,MM24,MG25,MM26,MM27,MM28,MM29, MM32,MM33,NM22,NG23,NM24,NG25,NM26,NG27, OA22,OA23,OG24,OG25,PM22,PG23,PM24,PG25, QM22,QG23,QM24,QG25,QG26,QM27,QD28,QD29, QD32,QD33,QD34,QD35,QD36,RM22,RM24,RM25, RM26,RM27,RM28,RM29,RM32,RM33,RG34,RG35, RG36,RG37,RG38,RG39,SM22,SM23,SG24,SG25, SM26,SG27,SG28,SG29,SM32,SD33,TM22,TG23, UG22,UG23,UG24,UM25,UD26,UM27,WS22,WS23, WS24,WS25,WS26,WS27,WS28,ZG23,ZM24,ZG25, ZM26 ); subtype PERTP_type is string ( 1..2 ); subtype TPAUT_type is string ( 1..4 ); subtype TPASG_type is string ( 1..4 ); subtype TPAVL_type is string ( 1..4 ); subtype PERTC_type is string ( 1..2 ); subtype CPAUR_type is string ( 1..4 ); subtype CPASG_type is string ( 1..4 ); subtype CPAVL_type is string ( 1..4 ); subtype TRUTC_type is string ( 1..2 ); type TMTHD_type is ( B,C ); subtype TCARQ_type is string ( 1..3 ); subtype TCRAS_type is string ( 1..3 ); subtype TCRAV_type is string ( 1..3 ); subtype TRSA1_type is string ( 1..2 ); subtype TRSA2_type is string ( 1..2 ); subtype TRSA3_type is string ( 1..2 ); subtype TRSA4_type is string ( 1..2 ); subtype TRSA5_type is string ( 1..2 ); ------------------------- KF2 ------------------------------ subtype EQSEE_type is string ( 1..2 ); subtype EQSSE_type is string ( 1..2 ); subtype MEARD_type is string ( 1..3 ); subtype MEASG_type is string ( 1..3 ); subtype MEPOS_type is string ( 1..3 ); subtype ESSA1_type is string ( 1..2 ); subtype ESSA2_type is string ( 1..2 ); subtype ESSA3_type is string ( 1..2 ); subtype ESSA4_type is string ( 1..2 ); subtype ESSA5_type is string ( 1..2 ); subtype ESSA6_type is string ( 1..2 ); subtype ESSA7_type is string ( 1..2 ); subtype ESSA8_type is string ( 1..2 ); subtype ESSA9_type is string ( 1..2 ); subtype EQREE_type is string ( 1..2 ); subtype EQRED_type is string ( 1..2 ); subtype MEMRA_type is string ( 1..3 ); subtype ERSA1_type is string ( 1..2 ); subtype ERSA2_type is string ( 1..2 ); subtype ERSA3_type is string ( 1..2 ); subtype ERSA4_type is string ( 1..2 ); subtype ERSA5_type is string ( 1..2 ); subtype ERSA6_type is string ( 1..2 ); subtype ERSA7_type is string ( 1..2 ); subtype ERSA8_type is string ( 1..2 ); ------------------------- KF3 ------------------------------ subtype SDOC_type is string ( 1..4 ); subtype READF_type is string ( 1..1 ); subtype REASF_type is string ( 1..1 ); subtype PRRAF_type is string ( 1..1 ); subtype PRREF_type is string ( 1..3 ); subtype ESRAF_type is string ( 1..1 ); subtype ESREF_type is string ( 1..3 ); subtype ERRAF_type is string ( 1..1 ); subtype ERREF_type is string ( 1..3 ); subtype TRRAF_type is string ( 1..1 ); subtype TRREF_type is string ( 1..3 ); subtype SECRF_type is string ( 1..3 ); subtype TERRF_type is string ( 1..3 ); subtype CARAF_type is string ( 1..1 ); subtype CADAF_type is YYMMDD_type; subtype LIMF_type is string ( 1..1 ); subtype RLIMF_type is string ( 1..1 ); subtype RICDF_type is YYMMDD_type; subtype RESPF_type is string ( 1..5 ); ------------------------- KF4 ------------------------------ subtype SMCC1_type is string ( 1..2 ); subtype SMRA1_type is string ( 1..2 ); subtype SMAA1_type is string ( 1..2 ); subtype SMRC1_type is string ( 1..2 ); subtype SMAC1_type is string ( 1..2 ); subtype SMCC2_type is string ( 1..2 ); subtype SMRA2_type is string ( 1..2 ); subtype SMAA2_type is string ( 1..2 ); subtype SMRC2_type is string ( 1..2 ); subtype SMAC2_type is string ( 1..2 ); subtype SMCC3_type is string ( 1..2 ); subtype SMRA3_type is string ( 1..2 ); subtype SMAA3_type is string ( 1..2 ); subtype SMRC3_type is string ( 1..2 ); subtype SMAC3_type is string ( 1..2 ); subtype SMCC4_type is string ( 1..2 ); subtype SMRA4_type is string ( 1..2 ); subtype SMAA4_type is string ( 1..2 ); subtype SMRC4_type is string ( 1..2 ); subtype SMAC4_type is string ( 1..2 ); subtype GCCLA_type is string ( 1..2 ); subtype GCCLB_type is string ( 1..2 ); subtype GCCLC_type is string ( 1..2 ); subtype SPCLU_type is string ( 1..9 ); ------------------------- KN1 ------------------------------ type PRMA_type is ( AAW ,AMW ,ASU ,ASW ,CCC ,CON ,ELW , FSO ,INT ,LOG ,MIW ,MOB ,NCO ,SPW , STW ,ATN ,ELT ,IOP ,MEP ,MSA ,SAR ); subtype MARAT_type is string ( 1..1 ); subtype MAREA_type is string ( 1..3 ); subtype CHDAT_type is YYMMDD_type; subtype FMART_type is string ( 1..1 ); subtype FCDAT_type is YYMMDD_type; -------------------------------------------------------------- -- Unitrep field types for L, M -------------------------------------------------------------- subtype MEQPT_type is string ( 1..13 ); type FORDV_type is ( C,B,F,H,D,I,J,K,T,U,G,X,Y ); subtype MEPSA_type is string ( 1..3 ); subtype METAL_type is string ( 1..3 ); subtype MEPSD_type is string ( 1..3 ); subtype MEORD_type is string ( 1..3 ); subtype MEORN_type is string ( 1..3 ); subtype MEORC_type is string ( 1..3 ); subtype MEORO_type is string ( 1..3 ); subtype CREWA_type is string ( 1..2 ); subtype CREAL_type is string ( 1..2 ); subtype CREWF_type is string ( 1..2 ); subtype CRMRD_type is string ( 1..2 ); subtype CRMRN_type is string ( 1..2 ); subtype CRMRC_type is string ( 1..2 ); subtype CRMRO_type is string ( 1..2 ); type MEREC_type is ( AL,AS,CM,CO,DF,DL,EC,EM,EL,FL,HH, HY,IR,LL,LA,MO,OP,PH,RA,RM,SG,SL, SP,TL,TM,TV,UV,VI,WX,MP,XX ); -- SPECIAL CHECK FOR Merec_Types "#" ------------------------- M -------------------------------- subtype TEGEO_type is string ( 1..6 ); -------------------------------------------------------------- -- Unitrep field types for N, P, Q -------------------------------------------------------------- type PIN_type is ( A,B,D,E,F,G,H,K,L,M,N,P,R,S ); subtype FRQNO_type is string ( 1..5 ); type PLEAC_type is ( A,C ); type DDP_type is ( ND,ID,AD,MD,LD ); subtype DDPRD_type is YYMMDDHH_type; subtype MDT_type is DDDHH_type; subtype PUTCV_type is string ( 1..5 ); ------------------------- P -------------------------------- subtype PEQPT_type is string ( 1..13 ); subtype TPGEO_type is string ( 1..6 ); type ALTYP_type is ( AA,AB,AE,AL,AP,AR,AU,BD,BG,BN, BO,CD,CP,CS,DA,DB,DC,DD,DE,DF, DG,DH,DJ,DK,DL,DM,DN,DS,DW,EA, EG,IP,LC,LS,LT,ME,NE,PE,PG,PN, PS,RC,RN,RP,SA,SC,SD,SG,SI,SL, SM,SN,TA,TC,TD,TE,TF,TG,TL,TM, TN,TP,TR,TS,TT,TW,WR,WX ); subtype NUMBR_type is string ( 1..3 ); subtype NUMEA_type is string ( 1..3 ); subtype ALRET_type is HHHMM_type; ------------------------- Q -------------------------------- subtype NUSEQ_type is string ( 1..3 ); type WPNCO_type is ( CO, EL, IR, PH, RA, SG, SL, VI ); subtype NUQPT_type is string ( 1..10 ); subtype DSGEO_type is string ( 1..6 ); subtype NUMWR_type is string ( 1..2 ); subtype NUMWB_type is string ( 1..2 ); subtype NUGUN_type is string ( 1..2 ); subtype RTIME_type is string ( 1..5 ); subtype DSSTA_type is string ( 1..1 ); subtype RFDGS_type is string ( 1..5 ); subtype NUSTO_type is string ( 1..3 ); subtype NUECC_type is string ( 1..2 ); -------------------------------------------------------------- -- Unitrep field types for R -------------------------------------------------------------- subtype SEQ_type is integer range 1..9; subtype TOT_type is integer range 1..9; subtype LABEL_type is string ( 1..5 ); subtype RMKID_type is string ( 1..27 ); subtype REMRK_type is string ( 1.. 21 ); -------------------------------------------------------------- -- Unitrep field types for T -------------------------------------------------------------- subtype TEQPT_type is string ( 1..11 ); subtype MESEN_type is string ( 1..4 ); subtype DECON_type is string ( 1..1 ); type MECUS_type is ( CT,TT,MT,DT,XT,CF,TF,MF,DF,XF, CE,CS,RA,FT ); type AVCAT_type is ( A,B,C,D,F,G,H,J ); type RESND_type is ( A,B,C,E,F ); subtype ERDTE_type is YYMMDD_type; subtype EXDAC_type is string ( 1..1 ); subtype CPGEO_type is string ( 1..4 ); subtype CFGEO_type is string ( 1..4 ); subtype EQDEP_type is YYMMDD_type; subtype EQARR_type is YYMMDD_type; subtype TPIN_type is string ( 1..5 ); subtype TLEAC_type is string ( 1..1 ); subtype TLEQE_type is string ( 1..2 ); ------------------------- TF1 ------------------------------ subtype UEQPT_type is string ( 1..11 ); type MEQS_type is ( A,D,F,G,K,L,M,N,P,Q,R,T,U,V, Y,Z,X,B,C,E,H,J,S,W ); type SEDY_type is ( A,B,C,F,I,J,M,N,R,V,W,Y,Z,X ); -- special check for 0,5,7,9 type TEDY_type is ( C,D,F,G,H,M,N,P,T,X,Z ); subtype ERRDY_type is YYMMDD_type; type AVAIL_type is ( A,B,C,D,E,F ); subtype DCNDY_type is string ( 1..5 ); subtype EQRET_type is YYMMDD_type; subtype GEOGR_type is string ( 1..4 ); subtype OPERL_type is YYMMDD_type; subtype DAFLD_type is string ( 1..4 ); -------------------------------------------------------------- -- Unitrep field types for V -------------------------------------------------------------- subtype ACGEO_type is string ( 1..4 ); subtype ACITY_type is string ( 1..2 ); subtype ADATE_type is YYMMDD_type; subtype MDATE_type is string ( 1..4 ); subtype RDATE_type is YYMMDD_type; -------------------------------------------------------------- -- Unitrep field types for X -------------------------------------------------------------- subtype GCMD_type is string ( 1..6 ); subtype TDATE_type is YYMMDD_type; subtype TRGEO_type is string ( 1..4 ); subtype DEPDT_type is YYMMDD_type; subtype ARRDT_type is YYMMDD_type; subtype RPTOR_type is string ( 1..6 ); subtype INTR1_type is string ( 1..6 ); subtype INTR2_type is string ( 1..6 ); subtype SBRPT_type is string ( 1..6 ); -------------------------------------------------------------------- -- THESE ARE FIELDS DEFINED BY SAI -------------------------------------------------------------------- -- type Department_type is ( W,F,M,N,E,D,X,Z ); type UIC2_Department_type is ( C,D,E,G,H,K,L,N,R,S ); type RECONN_type is ( AL, AS, CM, CO, DF, DL, EC, EM, EL, FL, HH, HY, IR, LL, LA, MO, OP, PH, RA, RM, SG, SL, SP, TL, TM, TV, UV, VI, WX, MP, XX ); type Alphabetic_Types is ( 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 ); type Error_Msg_Types is ( Bad_Field, Bad_Sequence, No_Header, No_End, Field_Required, Bad_Card_Type, Mutually_Exclusive, Can_Not_Validate_Correctly ); -- -- end Unitrep_field_types; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --urprocs.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE UR_PROCEDURES -- -- File name : URPROCS.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with Unitrep_lines_and_fields; use Unitrep_lines_and_fields; package UR_procedures is -- -- This package is used to validate the operator entry for subtypes -- of the Unitrep_field_names. This approach was necessary due -- to the size of the case statement and limitations of TeleSoft. -- -- Note : once again, the VALUE attribute is used to determine the -- the validity of discrete fields; constraint_errors are -- passed thru to the Get_Unitrep_Field exception handler. -- -- procedure Validate_ABC_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ); -- procedure Validate_DGJ_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ); -- procedure Validate_K_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ); -- procedure Validate_LM_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ); -- procedure Validate_NPQ_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ); -- procedure Validate_RTV_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ); -- procedure Validate_XEH_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ); -- end UR_procedures; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --urprocs.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE UR_PROCEDURES -- -- File name : URPROCS.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with Unitrep_field_types; use Unitrep_field_types; package body UR_procedures is -- -- ----------------------------- procedure Validate_ABC_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ) is ----------------------------- -- UDC_value : UDC_type; ULC_value : ULC_type; MAJOR_value : MAJOR_type; REVAL_value : REVAL_type; SCLAS_value : SCLAS_type; COAFF_value : COAFF_type; -- begin -- case field_type is -- ------------------------------- A ----------------------------- -- when UDC => if field_string(1..1) < "0" or field_string(1..1) > "9" then UDC_value := UDC_type'value(field_string(1..field_length)); end if; -- when ANAME => null; -- when UTC => null; -- when ULC => if field_string(1..3) /= "FOR" then ULC_value := ULC_type'value(field_string(1..field_length)); end if; -- when MJCOM => null; -- when MAJOR => MAJOR_value := MAJOR_type'value(field_string(1..field_length)); -- when REVAL => REVAL_value := REVAL_type'value(field_string(1..field_length)); -- when TPSN => null; -- when SCLAS => SCLAS_value := SCLAS_type'value(field_string(1..field_length)); -- --------------------------- B -------------------------- -- when LNAME => null; -- --------------------------- C -------------------------- -- when COAFF => if field_string(1..2) /= "DO" or field_string(1..2) /= "IN" or field_string(1..2) /= "IS" then COAFF_value := COAFF_type'value(field_string(1..field_length)); end if; -- when MONOR => null; -- when others => null; -- end case; -- end Validate_ABC_Fields; -- ----------------------------- procedure Validate_DGJ_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ) is ----------------------------- -- CSERV_value : CSERV_type; ACTIV_value : ACTIV_type; FLAG_value : FLAG_type; PUIC_value : PUIC_type; CBCOM_value : CBCOM_type; DFCON_value : DFCON_type; NUCIN_value : NUCIN_type; -- BILET_value : BILET_type; CORNK_value : CORNK_type; MMCMD_value : MMCMD_type; -- MEDIA_value : MEDIA_type; TADC_value : TADC_type; -- TPERS_value : TPERS_type; CCEBY_value : CCEBY_type; -- begin -- case field_type is -- ----------------------------------- D -------------------------- -- when CSERV => if field_string(1..1) < "1" or field_string(1..1) > "9" then CSERV_value := CSERV_type'value(field_string(1..field_length)); end if; -- when OPCON | ADCON => null; -- when HOGEO | PRGEO => null; -- when EMBRK => null; -- when ACTIV => if field_string(1..2) /= "IN" then ACTIV_value := ACTIV_type'value(field_string(1..field_length)); end if; -- when FLAG => FLAG_value := FLAG_type'value(field_string(1..field_length)); -- when PUIC => PUIC_value := PUIC_type'value(field_string(1..field_length)); -- when CBCOM => CBCOM_value := CBCOM_type'value(field_string(1..field_length)); -- when DFCON => if field_string(1..1) < "1" or field_string(1..1) > "5" then DFCON_value := DFCON_type'value(field_string(1..field_length)); end if; -- when POINT => null; -- when NUCIN => NUCIN_value := NUCIN_type'value(field_string(1..field_length)); -- when PCTEF => null; -- ------------------------- DM1 -------------------------- -- when BILET => BILET_value := BILET_type'value(field_string(1..field_length)); -- when CORNK => CORNK_value := CORNK_type'value(field_string(1..field_length)); -- when CONAM => null; -- when MMCMD => if field_string(1..1) /= "#" then MMCMD_value := MMCMD_type'value(field_string(1..field_length)); end if; -- ------------------------- DN1 -------------------------- -- when NTASK => null; -- when MODFG => null; -- when NDEST => null; -- when CXMRS => null; -- ------------------------- G -------------------------- -- when TCAA => null; -- when MEDIA => MEDIA_value := MEDIA_type'value(field_string(1..field_length)); -- when TADC => TADC_value := TADC_type'value(field_string(1..field_length)); -- when ROUTE | XRTE => null; -- ------------------------- J -------------------------- -- when TPERS => if field_string(1..2) /= "AT" then TPERS_value := TPERS_type'value(field_string(1..field_length)); end if; -- when PEGEO => null; -- when STRUC | AUTH | ASGD | POSTR => null; -- when DEPS | TDEPS | CASPW | CCASP => null; -- when CCEBY => CCEBY_value := CCEBY_type'value(field_string(1..field_length)); -- ------------------------- JM1 -------------------------- -- when SCATD => null; -- when MGO | AGO | NA | NFO | MENL | NAVO | NAVE | OTHOF | OTHEN | PIAOD => null; -- when others => null; -- end case; -- end Validate_DGJ_Fields; -- --------------------------- procedure Validate_K_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ) is --------------------------- -- TREAD_value : TREAD_type; REASN_value : REASN_type; PRRES_value : PRRES_type; ESRES_value : ESRES_type; ERRES_value : ERRES_type; TRRES_value : TRRES_type; -- DOCID_value : DOCID_type; TMTHD_value : TMTHD_type; -- PRMA_value : PRMA_type; -- begin -- case field_type is -- ------------------------- K -------------------------- -- when TREAD => TREAD_value := TREAD_type'value(field_string(1..field_length)); -- when READY | PRRAT | ESRAT | ERRAT | TRRAT | CARAT | LIM => null; -- when REASN => REASN_value := REASN_type'value(field_string(1..field_length)); -- when PRRES => PRRES_value := PRRES_type'value(field_string(1..field_length)); -- when ESRES => ESRES_value := ESRES_type'value(field_string(1..field_length)); -- when ERRES => ERRES_value := ESRES_type'value(field_string(1..field_length)); -- when TRRES => TRRES_value := TRRES_type'value(field_string(1..field_length)); -- when SECRN => null; -- when TERRN => null; -- when RLIM => null; -- ------------------------- KF1 -------------------------- -- when DOCNR => null; -- when DOCID => DOCID_value := DOCID_type'value(field_string(1..field_length)); -- when PERTP | PERTC | TRUTC => null; -- when TPAUT | TPASG | TPAVL | CPAUR | CPASG | CPAVL => null; -- when TMTHD => TMTHD_value := TMTHD_type'value(field_string(1..field_length)); -- when TCARQ | TCRAS | TCRAV => null; -- when TRSA1 | TRSA2 | TRSA3 | TRSA4 | TRSA5 => null; -- ------------------------- KF2 -------------------------- -- when EQSEE | EQSSE | EQREE | EQRED => null; -- when MEARD | MEASG | MEPOS => null; -- when ESSA1 | ESSA2 | ESSA3 | ESSA4 | ESSA5 | ESSA6 | ESSA7 | ESSA8 | ESSA9 => null; -- when MEMRA => null; -- when ERSA1 | ERSA2 | ERSA3 | ERSA4 | ERSA5 | ERSA6 | ERSA7 | ERSA8 => null; -- ------------------------- KF3 -------------------------- -- when SDOC => null; -- when READF | REASF => null; -- when PRRAF | ESRAF | ERRAF | TRRAF => null; -- when PRREF | ESREF | ERREF | TRREF | SECRF | TERRF => null; -- when CARAF => null; -- when LIMF | RLIMF => null; -- when RESPF => null; -- ------------------------- KF4 -------------------------- -- when SMCC1 | SMCC2 | SMCC3 | SMCC4 => null; -- when SMRA1 | SMRA2 | SMRA3 | SMRA4 => null; -- when SMAA1 | SMAA2 | SMAA3 | SMAA4 => null; -- when SMRC1 | SMRC2 | SMRC3 | SMRC4 => null; -- when SMAC1 | SMAC2 | SMAC3 | SMAC4 => null; -- when GCCLA | GCCLB | GCCLC => null; -- when SPCLU => null; -- ------------------------- KN1 -------------------------- -- when PRMA => PRMA_value := PRMA_type'value(field_string(1..field_length)); -- when MARAT | FMART => null; -- when MAREA => null; -- when others => null; -- end case; -- end Validate_K_Fields; -- ---------------------------- procedure Validate_LM_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ) is ---------------------------- -- FORDV_value : FORDV_type; MEREC_value : MEREC_type; -- begin -- case field_type is -- ------------------------- L, M -------------------------- -- when MEQPT => null; -- when FORDV => FORDV_value := FORDV_type'value(field_string(1..field_length)); -- when MEPSA | METAL | MEPSD | MEORD | MEORN | MEORC | MEORO => null; -- when CREWA | CREAL | CREWF | CRMRD | CRMRN | CRMRC | CRMRO => null; -- when MEREC => if field_string(1..1) /= "#" then MEREC_value := MEREC_type'value(field_string(1..field_length)); end if; -- ------------------------- M -------------------------- -- when TEGEO => null; -- when others => null; -- end case; -- end Validate_LM_Fields; -- ----------------------------- procedure Validate_NPQ_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ) is ----------------------------- -- PIN_value : PIN_type; PLEAC_value : PLEAC_type; DDP_value : DDP_type; -- ALTYP_value : ALTYP_type; -- WPNCO_value : WPNCO_type; -- begin -- case field_type is -- ------------------------- N, P, Q -------------------------- -- when PIN => PIN_value := PIN_type'value(field_string(1..field_length)); -- when FRQNO => null; -- when PLEAC => PLEAC_value := PLEAC_type'value(field_string(1..field_length)); -- when DDP => DDP_value := DDP_type'value(field_string(1..field_length)); -- when PUTCV => null; -- ------------------------- P -------------------------- -- when PEQPT => null; -- when TPGEO => null; -- when ALTYP => ALTYP_value := ALTYP_type'value(field_string(1..field_length)); -- when NUMBR | NUMEA => null; -- ------------------------- Q -------------------------- -- when NUSEQ => null; -- when WPNCO => WPNCO_value := WPNCO_type'value(field_string(1..field_length)); -- when NUQPT => null; -- when DSGEO => null; -- when NUMWR | NUMWB | NUGUN => null; -- when RTIME | RFGDS => null; -- when DSSTA => null; -- when NUSTO => null; -- when NUECC => null; -- when others => null; -- end case; -- end Validate_NPQ_Fields; -- ----------------------------- procedure Validate_RTV_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ) is ----------------------------- -- SEQ_value : SEQ_type; TOT_value : TOT_type; -- MECUS_value : MECUS_type; AVCAT_value : AVCAT_type; RESND_value : RESND_type; -- MEQS_value : MEQS_type; SEDY_value : SEDY_type; TEDY_value : TEDY_type; AVAIL_value : AVAIL_type; -- begin -- case field_type is -- ------------------------- R -------------------------- -- when SEQ => SEQ_value := SEQ_type'value(field_string(1..field_length)); -- when TOT => TOT_value := TOT_type'value(field_string(1..field_length)); -- when LABEL => null; -- when RMKID => null; -- when REMRK => null; -- ------------------------- T -------------------------- -- when TEQPT => null; -- when MESEN => null; -- when DECON => null; -- when MECUS => MECUS_value := MECUS_type'value(field_string(1..field_length)); -- when AVCAT => AVCAT_value := AVCAT_type'value(field_string(1..field_length)); -- when RESND => RESND_value := RESND_type'value(field_string(1..field_length)); -- when EXDAC => null; -- when CPGEO | CFGEO => null; -- when TPIN => null; -- when TLEAC => null; -- when TLEQE => null; -- ------------------------- TF1 -------------------------- -- when UEQPT => null; -- when MEQS => MEQS_value := MEQS_type'value(field_string(1..field_length)); -- when SEDY => SEDY_value := SEDY_type'value(field_string(1..field_length)); -- when TEDY => TEDY_value := TEDY_type'value(field_string(1..field_length)); -- when AVAIL => AVAIL_value := AVAIL_type'value(field_string(1..field_length)); -- when DCNDY => null; -- when GEOGR | DAFLD => null; -- ------------------------- V -------------------------- -- when ACGEO | MDATE => null; -- when ACITY => null; -- when others => null; -- end case; -- end Validate_RTV_Fields; -- ----------------------------- procedure Validate_XEH_Fields( field_string : in string; field_length : in natural; field_type : in Unitrep_field_names ) is ----------------------------- -- H_card_number_value : H_card_number_type; Day_of_month_value : Day_of_month_type; Month_value : Month_type; Year_value : Year_type; Real_or_Exercise_value : Real_or_Exercise_type; -- begin -- case field_type is -- ------------------------- X -------------------------- -- when GCMD | RPTOR | INTR1 | INTR2 | SBRPT => null; -- when TRGEO => null; -- when ATACH => null; -- ------------------------- E -------------------------- -- when NOT_USED => null; -- ------------------------- H -------------------------- -- when H_CARD_NUMBER => H_card_number_value := H_card_number_type'value(field_string(1..field_length)); -- when DAY_OF_MONTH => Day_of_month_value := Day_of_month_type'value(field_string(1..field_length)); -- when MONTH => Month_value := Month_type'value(field_string(1..field_length)); -- when YEAR => Year_value := Year_type'value(field_string(1..field_length)); -- when REAL_OR_EXERCISE => Real_or_exercise_value := Real_or_exercise_type'value(field_string(1..field_length)); -- when others => null; -- end case; -- end Validate_XEH_Fields; -- -- end UR_procedures; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --unitrep.sp --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE UNITREP_INTERFACE -- -- File name : UNITREP.SP -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with UNITREP_LINES_AND_FIELDS; use UNITREP_LINES_AND_FIELDS; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with LINKED_LIST_PROCEDURES; use LINKED_LIST_PROCEDURES; package UNITREP_INTERFACE is -- -------------------------------- procedure GET_UNITREP_LINE_TYPE (LINE_TYPE : out UNITREP_LINE_NAMES); -------------------------------- -- -- ---------------------------------- procedure PARSE_UNITREP_LINE_TYPE (MESSAGE_LINE : in NODE; LINE_TYPE : out UNITREP_LINE_NAMES); ---------------------------------- -- -- ---------------------------- procedure GET_UNITREP_FIELD (FIELD_TYPE : in UNITREP_FIELD_NAMES; FIELD_GOTTEN : in out STRING; FIELD_POSITION : in POSITIVE; FIELD_LENGTH : in POSITIVE; COMMAND_GOTTEN : in out COMMAND; COMMAND_FLAG : in out BOOLEAN); ---------------------------- -- -- end UNITREP_INTERFACE; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --unitrep.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE UNITREP_INTERFACE -- -- File name : UNITREP.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with TEXT_IO; use TEXT_IO; with UNITREP_FIELD_TYPES; use UNITREP_FIELD_TYPES; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with UR_PROCEDURES; use UR_PROCEDURES; with STATIC_GET_FIELD_UTILITIES; use STATIC_GET_FIELD_UTILITIES; package body UNITREP_INTERFACE is -- LEN : NATURAL; -- used by most routines in conjunction with the -- following local procedure -- -------------------------------------------- -- string parser -- -- ------------- -- -- compute number of non-blank characters -- -------------------------------------------- ---------------------------- procedure GET_STRING_LENGTH (IN_STRING : in STRING; LENGTH : out NATURAL) is ---------------------------- -- TEMPORARY_LENGTH : NATURAL := 0; -- begin -- for I in IN_STRING'FIRST..IN_STRING'LAST loop if IN_STRING (I..I) /= " " then TEMPORARY_LENGTH := TEMPORARY_LENGTH + 1; end if; end loop; -- LENGTH := TEMPORARY_LENGTH; -- end GET_STRING_LENGTH; -- -------------------------------- procedure GET_UNITREP_LINE_TYPE (LINE_TYPE : out UNITREP_LINE_NAMES) is -------------------------------- -- LINE_TYPE_STRING : STRING (1..3); -- -- using mmip.read, so need to ignore any edit commands -- IGNORE_COMMAND : BOOLEAN; NO_COMMAND : COMMAND; -- begin -- -- get the line type input from the user ( mmip routine ) -- GOTO_CRT_POSITION (12, 60); READ (TEXT => LINE_TYPE_STRING, NUM_CHAR => 3, COMMAND_FLAG => IGNORE_COMMAND, EDIT_COMMAND => NO_COMMAND); -- -- compute length of non-blank input -- GET_STRING_LENGTH (LINE_TYPE_STRING, LEN); -- -- make sure its a valid type -- LINE_TYPE := UNITREP_LINE_NAMES'VALUE (LINE_TYPE_STRING (1..LEN)); -- -- display error message and get the new input -- exception -- when CONSTRAINT_ERROR => -- PROMPT ("Illegal Unitrep line type, try again"); GET_UNITREP_LINE_TYPE (LINE_TYPE); -- -- end GET_UNITREP_LINE_TYPE; -- -- ---------------------------------- procedure PARSE_UNITREP_LINE_TYPE (MESSAGE_LINE : in NODE; LINE_TYPE : out UNITREP_LINE_NAMES) is ---------------------------------- -- -- begin -- -- the line_type in a Unitrep message is contained in the Record_ID -- field; a fixed location within the string. Need to compute the -- number of non-blank characters first, then convert to enum type -- GET_STRING_LENGTH (MESSAGE_LINE.TEXT_LINE (6..8), LEN); -- LINE_TYPE := UNITREP_LINE_NAMES'VALUE (MESSAGE_LINE.TEXT_LINE (6..6 + LEN - 1)); -- -- if the line is illegal, pick the nil default -- exception -- when CONSTRAINT_ERROR => LINE_TYPE := NIL; -- -- display an alert -- PROMPT ("This line is not a legal Unitrep message type"); -- end PARSE_UNITREP_LINE_TYPE; -- -- procedure ACCEPT_DATE_TIME_TYPE (FIELD_TYPE : in UNITREP_FIELD_NAMES; FIELD_GOTTEN : in out STRING; FIELD_POSITION : in POSITIVE; FIELD_LENGTH : in POSITIVE; COMMAND_GOTTEN : in out COMMAND; COMMAND_FLAG : in out BOOLEAN) is -- DUMMY_STRING : STRING (1..3); BLANK_STRING : STRING (1..80) := (others => ' '); -- -- Note : dummy_string is used because of a TeleSoft bug -- one -- should only have to pass the substring of field_gotten -- begin -- case FIELD_TYPE is -- when DDPRD => -- -- yymmddhh -- GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..2), FIELD_POSITION, 0, 99, '0', COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..2) := FIELD_GOTTEN (3..4); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 2, 1, 12, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (3..4) := DUMMY_STRING (1..2); DUMMY_STRING (1..2) := FIELD_GOTTEN (5..6); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 4, 1, 31, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (5..6) := DUMMY_STRING (1..2); DUMMY_STRING (1..2) := FIELD_GOTTEN (7..8); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 6, 0, 24, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (7..8) := DUMMY_STRING (1..2); -- when MDT => -- -- dddhh -- GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..3), FIELD_POSITION, 1, 366, '0', COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..2) := FIELD_GOTTEN (4..5); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 3, 0, 24, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (4..5) := DUMMY_STRING (1..2); -- when ALRET => -- -- hhhmm -- GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..3), FIELD_POSITION, 0, 999, '0', COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..2) := FIELD_GOTTEN (4..5); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 3, 0, 59, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (4..5) := DUMMY_STRING (1..2); -- when PLETD | DETA => -- -- mmddhh -- GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..2), FIELD_POSITION, 1, 12, '0', COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..2) := FIELD_GOTTEN (3..4); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 2, 1, 31, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (3..4) := DUMMY_STRING (1..2); DUMMY_STRING (1..2) := FIELD_GOTTEN (5..6); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 4, 0, 24, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (5..6) := DUMMY_STRING (1..2); -- when RWDTE | XDATE => -- -- dddyy -- GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..3), FIELD_POSITION, 1, 366, '0', COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..2) := FIELD_GOTTEN (4..5); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 3, 0, 99, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (4..5) := DUMMY_STRING (1..2); -- when PICDA | CADAT | RICDA | CADAF | RICDF | CHDAT | FCDAT | ERDTE | EQDEP | EQARR | ERRDY | EQRET | OPERL | ADATE | RDATE | TDATE | DEPDT | ARRDT => -- -- yymmdd -- GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..2), FIELD_POSITION, 0, 99, '0', COMMAND_FLAG, COMMAND_GOTTEN); DUMMY_STRING (1..2) := FIELD_GOTTEN (3..4); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 2, 1, 12, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (3..4) := DUMMY_STRING (1..2); DUMMY_STRING (1..2) := FIELD_GOTTEN (5..6); GET_CONSTRAINED_INTEGER (DUMMY_STRING (1..2), FIELD_POSITION + 4, 1, 31, '0', COMMAND_FLAG, COMMAND_GOTTEN); FIELD_GOTTEN (5..6) := DUMMY_STRING (1..2); -- when others => null; -- end case; -- -- if the entire string is not blank, don't accept it -- if FIELD_GOTTEN (1) = ' ' and FIELD_GOTTEN (1..FIELD_LENGTH) /= BLANK_STRING (1..FIELD_LENGTH) then raise CONSTRAINT_ERROR; end if; -- exception -- -- handle an erase field locally -- when ERASE_ERROR => -- COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); PUT (BLANK_STRING (1..FIELD_LENGTH)); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); ACCEPT_DATE_TIME_TYPE (FIELD_TYPE, FIELD_GOTTEN, FIELD_POSITION, FIELD_LENGTH, COMMAND_GOTTEN, COMMAND_FLAG); -- -- end ACCEPT_DATE_TIME_TYPE; -- -- ------------------------------------------------------------------- -- ---------------------------- procedure GET_UNITREP_FIELD (FIELD_TYPE : in UNITREP_FIELD_NAMES; FIELD_GOTTEN : in out STRING; FIELD_POSITION : in POSITIVE; FIELD_LENGTH : in POSITIVE; COMMAND_GOTTEN : in out COMMAND; COMMAND_FLAG : in out BOOLEAN) is ---------------------------- -- CLASS_VALUE : CLASSIFICATION_TYPE; UAC_VALUE : UAC_TYPE; UIC_VALUE : UIC_TYPE; -- BLANK_STRING : STRING (1..80) := (others => ' '); DUMMY_STRING : STRING (1..3); -- begin -- COMMAND_GOTTEN := NIL; COMMAND_FLAG := FALSE; -- -------------------------------------------------------------- case FIELD_TYPE is -------------------------------------------------------------- -- -- first check for date/time field types -- use special input -- when DDPRD | MDT | ALRET | PLETD | DETA | RWDTE | XDATE | PICDA | CADAT | RICDA | CADAF | RICDF | CHDAT | FCDAT | ERDTE | EQDEP | EQARR | ERRDY | EQRET | OPERL | ADATE | RDATE | TDATE | DEPDT | ARRDT => -- ACCEPT_DATE_TIME_TYPE (FIELD_TYPE, FIELD_GOTTEN, FIELD_POSITION, FIELD_LENGTH, COMMAND_GOTTEN, COMMAND_FLAG); -- -- card number and message number also use special input -- when CARD_NUMBER => GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..3), FIELD_POSITION, 1, 999, '0', COMMAND_FLAG, COMMAND_GOTTEN); -- when MESSAGE_NUMBER => GET_CONSTRAINED_INTEGER (FIELD_GOTTEN (1..3), FIELD_POSITION, 1, 999, '0', COMMAND_FLAG, COMMAND_GOTTEN); -- -- else, use the standard character read -------------------------------------------------- when others => -------------------------------------------------- READ (TEXT => FIELD_GOTTEN, NUM_CHAR => FIELD_LENGTH, COMMAND_FLAG => COMMAND_FLAG, EDIT_COMMAND => COMMAND_GOTTEN); -- -- check for the entry of a command or a blank field -- if not COMMAND_FLAG and FIELD_GOTTEN (1..FIELD_LENGTH) /= BLANK_STRING (1..FIELD_LENGTH) then -- -- can now compute the length of the non-blank input string -- GET_STRING_LENGTH (FIELD_GOTTEN, LEN); -- -- the actual validation is done by the following case -- For discrete types, the VALUE attribute is used to convert -- the string to the appropriate type, raising -- constraint_error when the input is illegal. -- --------------------------------------------------- case FIELD_TYPE is --------------------------------------------------- -- when STANDARD_NAMES => -- case FIELD_TYPE is -- when CLASSIFICATION => CLASS_VALUE := CLASSIFICATION_TYPE'VALUE (FIELD_GOTTEN (1..1)); -- when UAC => UAC_VALUE := UAC_TYPE'VALUE (FIELD_GOTTEN (1..LEN)); -- when RECORD_ID => null; -- when UIC | ORIGINATORS_UIC => UIC_VALUE := UIC_TYPE'VALUE (FIELD_GOTTEN (1..LEN)); -- when MESSAGE_TYPE => null; -- when others => null; -- end case; -- when ABC_NAMES => VALIDATE_ABC_FIELDS (FIELD_GOTTEN, LEN, FIELD_TYPE); -- when DGJ_NAMES => VALIDATE_DGJ_FIELDS (FIELD_GOTTEN, LEN, FIELD_TYPE); -- when K_NAMES => VALIDATE_K_FIELDS (FIELD_GOTTEN, LEN, FIELD_TYPE); -- when LM_NAMES => VALIDATE_LM_FIELDS (FIELD_GOTTEN, LEN, FIELD_TYPE); -- when NPQ_NAMES => VALIDATE_NPQ_FIELDS (FIELD_GOTTEN, LEN, FIELD_TYPE); -- when RTV_NAMES => VALIDATE_RTV_FIELDS (FIELD_GOTTEN, LEN, FIELD_TYPE); -- when XEH_NAMES => VALIDATE_XEH_FIELDS (FIELD_GOTTEN, LEN, FIELD_TYPE); -- when NIL => null; -- end case; -- end if; -- end case; ------------------------------------------------------------ -- exception -- -- process an illegal enumeration type conversion -- when CONSTRAINT_ERROR => -- PROMPT ("Illegal Unitrep field entry"); GOTO_CRT_POSITION (TOP_OF_WORK_AREA, FIELD_POSITION); COMMAND_FLAG := FALSE; COMMAND_GOTTEN := NIL; GET_UNITREP_FIELD (FIELD_TYPE, FIELD_GOTTEN, FIELD_POSITION, FIELD_LENGTH, COMMAND_GOTTEN, COMMAND_FLAG); -- when ERASE_ERROR => -- COMMAND_FLAG := TRUE; COMMAND_GOTTEN := ERASE_FIELD; -- -- end GET_UNITREP_FIELD; -- -- end UNITREP_INTERFACE; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --ureditor.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE UR_EDITOR -- -- File name : UREDITOR.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with UNITREP_LINES_AND_FIELDS; use UNITREP_LINES_AND_FIELDS; with UNITREP_INTERFACE; use UNITREP_INTERFACE; with FILE_GENERIC; use FILE_GENERIC; package UR_EDITOR is package UNITREP_ED is new FILE_GENERIC.FILED_GENERIC_MESSAGE_EDITOR (MAXIMUM_FIELDS_PER_LINE => UNITREP_MAXIMUM_FIELDS_PER_LINE, MAXIMUM_CHARACTERS_PER_LINE => UNITREP_MAXIMUM_CHARACTERS_PER_LINE, MAXIMUM_LINES_PER_MESSAGE => UNITREP_MAXIMUM_LINES_PER_MESSAGE, LINE_NAME => UNITREP_LINE_NAMES, GET_LINE_NAME => GET_UNITREP_LINE_TYPE, FIELD_NAME => UNITREP_FIELD_NAMES, LINE_STRUCTURE_FILE_NAME => "UNITREP.DES", FIELD_PROMPT_FILE_NAME => "URPROMPT.DES", PROMPT_VECTOR_FILE_NAME => "URPMTLUT.DES", GET_FIELD => GET_UNITREP_FIELD, PARSE_LINE_TYPE => PARSE_UNITREP_LINE_TYPE); -- end UR_EDITOR; -- package body UR_EDITOR is -- end UR_EDITOR; --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --saifap.txt --:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- -- -- Program unit: PACKAGE FILE_ACCESS -- -- File name : FAP.TXT -- -- -- -- =========================================== -- -- -- -- -- -- Produced by Veda Incorporated -- -- Version 1.0 April 15, 1985 -- -- -- -- -- -- This program unit is a member of the GMHF. It -- -- was developed using TeleSoft's Ada compiler, -- -- version 2.1 in a VAX/VMS environment, version -- -- 3.7 -- -- -- -- -- --||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||-- -- with CLASSIFICATION_DEFINITION; use CLASSIFICATION_DEFINITION; with MAN_MACHINE_INTERFACE; use MAN_MACHINE_INTERFACE; with TERMINAL_DEFINITION; use TERMINAL_DEFINITION; with DIRECT_IO; with CALENDAR; with TEXT_IO; use TEXT_IO; package body FILE_ACCESS is -- -- This package is available only to routines internal to -- the system driver package. The routines deal mainly with -- managing the messages of the internal database. -- External users may not utilize any of these routines. -- --------------------------------------------------- -- SAIC ******************************* --------------------------------------------------- suffix : string(1..3); file_5 : text_io.file_type; --------------------------------------------------- -- SAIC ******************************* --------------------------------------------------- ----------------------------------------------- -- -- local variables and direct_io instantiations -- ----------------------------------------------- -- RECORD_ERROR : exception; -- -- define the internal storage format of a message -- type MESSAGE_FORMAT is array (1..25) of STRING (1..80); -- type MESSAGE_RECORD is record CLASS : CLASSIFICATION; NUMBER_OF_LINES : POSITIVE; MONTH, DAY, YEAR : INTEGER; CONTENT : MESSAGE_FORMAT; end record; -- package DIRECTORY_IO is new DIRECT_IO (DIRECTORY_STRUCTURE); use DIRECTORY_IO; FILE_1 : DIRECTORY_IO.FILE_TYPE; RECORD_NUMBER : DIRECTORY_IO.POSITIVE_COUNT; -- DIRECTORY_RECORD : DIRECTORY_STRUCTURE; -- package MESSAGE_IO is new DIRECT_IO (MESSAGE_RECORD); use MESSAGE_IO; FILE_2 : MESSAGE_IO.FILE_TYPE; MESSAGE_RECORD_NUMBER : MESSAGE_IO.POSITIVE_COUNT; -- MESSAGE_DATA : MESSAGE_RECORD; -- LINE_NUMBER : POSITIVE; FOUND : BOOLEAN; -- MONTH, DAY, YEAR : INTEGER; -- package MESSAGE_TYPE_IO is new ENUMERATION_IO (AVAILABLE_TYPES); package NATURAL_IO is new INTEGER_IO (NATURAL); -- ---------------------------------------- -- local date routine ---------------------------------------- procedure GET_THE_DATE (MONTH, DAY, YEAR : out INTEGER) is -- COMPUTE_TIME : CALENDAR.TIME; -- begin -- COMPUTE_TIME := CALENDAR.CLOCK; -- MONTH := CALENDAR.MONTH (COMPUTE_TIME); DAY := CALENDAR.DAY (COMPUTE_TIME); YEAR := CALENDAR.YEAR (COMPUTE_TIME); -- end GET_THE_DATE; -- -- ---------------------------------------- procedure GET_DIRECTORY (TOP_OF_DIRECTORY : out DIRECTORY_ENTRY) is ---------------------------------------- CURRENT_POINTER : DIRECTORY_ENTRY; NEXT_POINTER : DIRECTORY_ENTRY; -- -- begin -- -- open the directory -- OPEN (FILE_1, INOUT_FILE, "MSGDRCTRY.DAT", ""); -- -- save the top of the directory linked list -- CURRENT_POINTER := new DIRECTORY_STRUCTURE; TOP_OF_DIRECTORY := CURRENT_POINTER; -- -- load the first directory entry -- RECORD_NUMBER := 1; READ (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); -- -- store the contents at current_pointer -- CURRENT_POINTER.MESSAGE_TYPE := DIRECTORY_RECORD.MESSAGE_TYPE; CURRENT_POINTER.MESSAGE_FILENAME := DIRECTORY_RECORD.MESSAGE_FILENAME; CURRENT_POINTER.NUMBER_OF_MESSAGES := DIRECTORY_RECORD.NUMBER_OF_MESSAGES; CURRENT_POINTER.PREVIOUS_MESSAGE_TYPE := null; CURRENT_POINTER.TYPE_STRING := DIRECTORY_RECORD.TYPE_STRING; CURRENT_POINTER.NUMBER_STRING := DIRECTORY_RECORD.NUMBER_STRING; -- -- now get the rest of the records -- while not END_OF_FILE (FILE_1) loop -- NEXT_POINTER := new DIRECTORY_STRUCTURE; RECORD_NUMBER := RECORD_NUMBER + 1; READ (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); -- NEXT_POINTER.MESSAGE_TYPE := DIRECTORY_RECORD.MESSAGE_TYPE; NEXT_POINTER.MESSAGE_FILENAME := DIRECTORY_RECORD.MESSAGE_FILENAME; NEXT_POINTER.NUMBER_OF_MESSAGES := DIRECTORY_RECORD.NUMBER_OF_MESSAGES; NEXT_POINTER.PREVIOUS_MESSAGE_TYPE := CURRENT_POINTER; NEXT_POINTER.TYPE_STRING := DIRECTORY_RECORD.TYPE_STRING; NEXT_POINTER.NUMBER_STRING := DIRECTORY_RECORD.NUMBER_STRING; -- CURRENT_POINTER.NEXT_MESSAGE_TYPE := NEXT_POINTER; CURRENT_POINTER := NEXT_POINTER; -- end loop; -- CLOSE (FILE_1); -- end GET_DIRECTORY; -- -------------------------------------- procedure GET_MESSAGE_OUT (DIRECTORY_POINTER : in DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL; MESSAGE_TEXT : in out MESSAGE) is -------------------------------------- -- MESSAGE_POINTER : NODE; -- -- begin -- PROMPT("Retrieving data base message"); -- -- open the message file and read the first record -- OPEN (FILE_2, INOUT_FILE, DIRECTORY_POINTER.MESSAGE_FILENAME & ".MSG", ""); -- if MESSAGE_NUMBER > DIRECTORY_POINTER.NUMBER_OF_MESSAGES OR MESSAGE_NUMBER = 0 then MESSAGE_RECORD_NUMBER := 1; else MESSAGE_RECORD_NUMBER := MESSAGE_IO.POSITIVE_COUNT ((MESSAGE_NUMBER * 4 + 1)); end if; -- READ (FILE_2, MESSAGE_DATA, MESSAGE_RECORD_NUMBER); -- -- load the first record into memory -- MESSAGE_POINTER := new MESSAGE_COMPONENT; -- MESSAGE_TEXT.HEAD := MESSAGE_POINTER; MESSAGE_TEXT.TAIL := MESSAGE_POINTER; MESSAGE_TEXT.CLASS := MESSAGE_DATA.CLASS; MESSAGE_TEXT.NUMBER_OF_LINES := MESSAGE_DATA.NUMBER_OF_LINES; -- MESSAGE_POINTER.NEXT_LINE := null; MESSAGE_POINTER.PREV_LINE := null; MESSAGE_POINTER.TEXT_LINE := MESSAGE_DATA.CONTENT (1); -- -- load the remaining lines into memory; an additional record must -- be read after 25, 50 and 75 lines -- LINE_NUMBER := 1; for I in 2..MESSAGE_DATA.NUMBER_OF_LINES loop LINE_NUMBER := LINE_NUMBER + 1; if LINE_NUMBER > 25 then MESSAGE_RECORD_NUMBER := MESSAGE_RECORD_NUMBER + 1; if NATURAL (MESSAGE_RECORD_NUMBER) >= (MESSAGE_NUMBER + 1) * 4 + 1 then raise RECORD_ERROR; end if; LINE_NUMBER := 1; READ (FILE_2, MESSAGE_DATA, MESSAGE_RECORD_NUMBER); end if; INSERT_AFTER (MESSAGE_TEXT, MESSAGE_POINTER); MESSAGE_POINTER := MESSAGE_POINTER.NEXT_LINE; MESSAGE_POINTER.TEXT_LINE := MESSAGE_DATA.CONTENT (LINE_NUMBER); end loop; -- -- CLOSE (FILE_2); -- exception -- when RECORD_ERROR => CLOSE (FILE_2); PROMPT ("Too many lines this message, only 100 lines saved"); -- end GET_MESSAGE_OUT; -- ----------------------------------------- procedure PUT_NEW_MESSAGE_IN (DIRECTORY_POINTER : in DIRECTORY_ENTRY; MESSAGE_TEXT : in MESSAGE) is ----------------------------------------- -- MESSAGE_POINTER : NODE; -- begin -- -- find the directory record and update the directory file -- RECORD_NUMBER := 1; OPEN (FILE_1, INOUT_FILE, "MSGDRCTRY.DAT", ""); while not END_OF_FILE (FILE_1) loop READ (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); if DIRECTORY_RECORD.MESSAGE_TYPE = DIRECTORY_POINTER.MESSAGE_TYPE then DIRECTORY_RECORD.NUMBER_OF_MESSAGES := DIRECTORY_RECORD.NUMBER_OF_MESSAGES + 1; NATURAL_IO.PUT (TO => DIRECTORY_RECORD.NUMBER_STRING, ITEM => DIRECTORY_RECORD.NUMBER_OF_MESSAGES); exit; else RECORD_NUMBER := RECORD_NUMBER + 1; end if; end loop; -- WRITE (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); CLOSE (FILE_1); -- -- open the message file -- OPEN (FILE_2, INOUT_FILE, DIRECTORY_RECORD.MESSAGE_FILENAME & ".MSG", ""); -- MESSAGE_RECORD_NUMBER := MESSAGE_IO.POSITIVE_COUNT ((DIRECTORY_RECORD.NUMBER_OF_MESSAGES) * 4 + 1); -- MESSAGE_DATA.CLASS := MESSAGE_TEXT.CLASS; MESSAGE_DATA.NUMBER_OF_LINES := MESSAGE_TEXT.NUMBER_OF_LINES; -- GET_THE_DATE (MONTH, DAY, YEAR); MESSAGE_DATA.MONTH := MONTH; MESSAGE_DATA.DAY := DAY; MESSAGE_DATA.YEAR := YEAR; -- -- write the message to disk, 25 lines per record -- MESSAGE_POINTER := MESSAGE_TEXT.HEAD; -- LINE_NUMBER := 1; for I in 1..MESSAGE_TEXT.NUMBER_OF_LINES loop MESSAGE_DATA.CONTENT (LINE_NUMBER) := MESSAGE_POINTER.TEXT_LINE; MESSAGE_POINTER := MESSAGE_POINTER.NEXT_LINE; LINE_NUMBER := LINE_NUMBER + 1; if LINE_NUMBER > 25 or I >= MESSAGE_TEXT.NUMBER_OF_LINES then LINE_NUMBER := 1; WRITE (FILE_2, MESSAGE_DATA, MESSAGE_RECORD_NUMBER); MESSAGE_RECORD_NUMBER := MESSAGE_RECORD_NUMBER + 1; if MESSAGE_RECORD_NUMBER >= MESSAGE_IO.POSITIVE_COUNT (((DIRECTORY_RECORD.NUMBER_OF_MESSAGES) + 1) * 4 + 1) then raise RECORD_ERROR; end if; end if; end loop; -- CLOSE (FILE_2); PROMPT("New message saved in data base"); -- --------------------------------------------------------------- -- create sequential message file for SAIC interface --------------------------------------------------------------- SUFFIX(1..3) := DIRECTORY_RECORD.NUMBER_STRING(3..5); FOR I IN 1..2 LOOP IF SUFFIX(I) = ' ' THEN SUFFIX(I) := '0'; END IF; END LOOP; text_io.create(file_5,out_file,"message"&"."&SUFFIX,""); -- message_pointer := message_text.head; -- line_number := 1; for i in 1 .. message_text.number_of_lines loop text_io.put_line(file_5,message_pointer.text_line); message_pointer := message_pointer.next_line; end loop; -- text_io.close(file_5); ------------------------------------------------------------------- -- stuff for SAIC ^^^^^^^^^^^^^^ ------------------------------------------------------------------- exception -- when RECORD_ERROR => CLOSE (FILE_2); PROMPT ("Too many lines this message, only 100 lines saved"); -- end PUT_NEW_MESSAGE_IN; -- ---------------------------------------------- procedure PUT_OLD_MESSAGE_BACK_IN (DIRECTORY_POINTER : in DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL; MESSAGE_TEXT : in MESSAGE) is ---------------------------------------------- -- MESSAGE_POINTER : NODE; -- begin -- -- validate the message number -- if MESSAGE_NUMBER > DIRECTORY_POINTER.NUMBER_OF_MESSAGES then PROMPT ("illegal record number selected"); return; end if; -- -- open the message file -- OPEN (FILE_2, INOUT_FILE, DIRECTORY_POINTER.MESSAGE_FILENAME & ".MSG", ""); -- -- must be a valid selection, process it -- MESSAGE_RECORD_NUMBER := MESSAGE_IO.POSITIVE_COUNT (MESSAGE_NUMBER * 4 + 1); -- MESSAGE_DATA.CLASS := MESSAGE_TEXT.CLASS; MESSAGE_DATA.NUMBER_OF_LINES := MESSAGE_TEXT.NUMBER_OF_LINES; -- GET_THE_DATE (MONTH, DAY, YEAR); MESSAGE_DATA.MONTH := MONTH; MESSAGE_DATA.DAY := DAY; MESSAGE_DATA.YEAR := YEAR; -- -- write the message to disk, 25 lines per record -- MESSAGE_POINTER := MESSAGE_TEXT.HEAD; -- LINE_NUMBER := 1; for I in 1..MESSAGE_TEXT.NUMBER_OF_LINES loop MESSAGE_DATA.CONTENT (LINE_NUMBER) := MESSAGE_POINTER.TEXT_LINE; MESSAGE_POINTER := MESSAGE_POINTER.NEXT_LINE; LINE_NUMBER := LINE_NUMBER + 1; if LINE_NUMBER > 25 or I >= MESSAGE_TEXT.NUMBER_OF_LINES then LINE_NUMBER := 1; WRITE (FILE_2, MESSAGE_DATA, MESSAGE_RECORD_NUMBER); MESSAGE_RECORD_NUMBER := MESSAGE_RECORD_NUMBER + 1; if NATURAL (MESSAGE_RECORD_NUMBER) >= (MESSAGE_NUMBER + 1) * 4 + 1 then raise RECORD_ERROR; end if; end if; end loop; -- CLOSE (FILE_2); PROMPT("Old message restored in data base"); -- --------------------------------------------------------------- -- create sequential message file for SAIC interface --------------------------------------------------------------- SUFFIX(1..3) := DIRECTORY_RECORD.NUMBER_STRING(3..5); FOR I IN 1..2 LOOP IF SUFFIX(I) = ' ' THEN SUFFIX(I) := '0'; END IF; END LOOP; text_io.create(file_5,out_file,"message"&"."&SUFFIX,""); -- message_pointer := message_text.head; -- line_number := 1; for i in 1 .. message_text.number_of_lines loop text_io.put_line(file_5,message_pointer.text_line); message_pointer := message_pointer.next_line; end loop; -- text_io.close(file_5); ------------------------------------------------------------------- -- stuff for SAIC ^^^^^^^^^^^^^^ ------------------------------------------------------------------- exception -- when RECORD_ERROR => CLOSE (FILE_2); PROMPT ("Too many lines this message, only 100 lines saved"); -- end PUT_OLD_MESSAGE_BACK_IN; -- -------------------------------------- procedure DELETE_MESSAGE_FROM_DATABASE (DIRECTORY_POINTER : in out DIRECTORY_ENTRY; MESSAGE_NUMBER : in NATURAL) is -------------------------------------- -- SCRATCH_MESSAGE : MESSAGE; ENTRY_NUMBER : NATURAL; -- begin -- -- validate the message number to be deleted -- if MESSAGE_NUMBER > DIRECTORY_POINTER.NUMBER_OF_MESSAGES or MESSAGE_NUMBER = 0 then PROMPT ("Illegal Message Delete Attempted"); return; -- else -- PROMPT ("Deleting Message Entry"); -- OPEN (FILE_1, INOUT_FILE, "MSGDRCTRY.DAT", ""); -- -- last entry deletion does not require repacking -- if MESSAGE_NUMBER /= DIRECTORY_POINTER.NUMBER_OF_MESSAGES then -- -- must re-pack the message file -- for I in MESSAGE_NUMBER + 1..DIRECTORY_POINTER.NUMBER_OF_MESSAGES loop ENTRY_NUMBER := NATURAL (I); GET_MESSAGE_OUT (DIRECTORY_POINTER, ENTRY_NUMBER, SCRATCH_MESSAGE); ENTRY_NUMBER := ENTRY_NUMBER - 1; PUT_OLD_MESSAGE_BACK_IN (DIRECTORY_POINTER, ENTRY_NUMBER, SCRATCH_MESSAGE); end loop; end if; -- RECORD_NUMBER := 1; while not END_OF_FILE (FILE_1) loop READ (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); exit when DIRECTORY_RECORD.MESSAGE_TYPE = DIRECTORY_POINTER.MESSAGE_TYPE; RECORD_NUMBER := RECORD_NUMBER + 1; end loop; -- DIRECTORY_RECORD.NUMBER_OF_MESSAGES := DIRECTORY_RECORD.NUMBER_OF_MESSAGES - 1; NATURAL_IO.PUT (TO => DIRECTORY_RECORD.NUMBER_STRING, ITEM => DIRECTORY_RECORD.NUMBER_OF_MESSAGES); WRITE (FILE_1, DIRECTORY_RECORD, RECORD_NUMBER); CLOSE (FILE_1); -- end if; -- end DELETE_MESSAGE_FROM_DATABASE; -- -- end FILE_ACCESS;