home *** CD-ROM | disk | FTP | other *** search
Text File | 1988-05-03 | 47.2 KB | 1,550 lines
:::::::::::::: CREATETB.PRO :::::::::::::: -------- SIMTEL20 Ada Software Repository Prologue ------------ -- -* -- Unit name : CREATE_TB -- Version : 850121 -- Author : Mitre Corp. -- DDN Address : wis_ada at mitre -- Date created : 21 JAN 85 -- Release date : 26 JAN 85 -- Last update : 26 JAN 85 -- Machine/System Compiled/Run on : Intellimac 7000M -- UNIX -- Telesoft unvalidated -- -* --------------------------------------------------------------- -- -* -- Keywords : Table builder, Text formatter -- ----------------: -- -- Abstract : -- CREATE_TB scans text files and creates a table by selecting -- specified line entries. The text files are assumed to contain -- standardized entries which are repeated in each file. CREATE_TB -- extracts a subset of these entries compressing their text into -- a specified column width for printing in a tabular form. The -- entries to be extracted and the width of each column may be -- specified by the user for each table. CREATE_TB will scan a group -- of files identified by a UNIX file pattern(including *, ?, or -- selectors [aeiou]) and it also recognizes PAGE headers of the form: -- -- :::::::::: --:::::::::: -- FILENAME or --FILENAME -- :::::::::: --:::::::::: -- -- as file separators. ----------------: -- -* ------------------ Revision history --------------------------- -- -* -- DATE VERSION AUTHOR HISTORY -- 12/15/84 1.0 Mitre Corp Initial Release -- 01/21/85 850121 Mitre Corp Mod to accept --::::::: headers -- Mod to correctly process blank -- lines when building heading -- Mod to stop on subfile header -- when building heading -- Moved PUT_DYNAMIC procedure -- from STR_PACK to CREATE_TB -- Added comments to STR_PACK and -- deleted several string -- procedures -- Converted subfile headers to -- Ada comments --::::::::: -- -* ------------------ Distribution and Copyright ----------------- -- -* -- This prologue must be included in all copies of this software. -- -- 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: Although there are -- no current plans to provide maintenance for CREATE_TB, -- we would appreciate your reporting problems and -- experiences to: -- -- wis_ada at mitre (net address) -- -- or call at: -- -- (703) 883-7697 -- -* ------------------ 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-------------------------------- :::::::::::::: calendar.text :::::::::::::: package CALENDAR is subtype TIME is LONG_INTEGER; end CALENDAR; :::::::::::::: create_tb.text :::::::::::::: pragma SOURCE_INFO(ON); with STR_PACK, HOST, TEXT_IO; use STR_PACK, TEXT_IO, INTEGER_IO; procedure CREATE_TABLE is MAX_NUMBER_OF_FIELDS : constant POSITIVE := 10; MAX_ID : constant POSITIVE := 3; MAX_LINE : constant POSITIVE := 55; MAX_COLUMN : CONSTANT INTEGER :=152; MAX_STRING : CONSTANT INTEGER :=255; FIELD_ID : array(1..MAX_NUMBER_OF_FIELDS) of STRING(1..MAX_ID); FIELD_STR : array(1..MAX_NUMBER_OF_FIELDS) of DYNAMIC_STRING; FIELD_LEN : array(1..MAX_NUMBER_OF_FIELDS) of INTEGER; NUMBER_OF_FIELDS : NATURAL; OPTION_SPACES : BOOLEAN := FALSE; OPTION_BAR : BOOLEAN := FALSE; LINE_IGNORED : BOOLEAN; LINE_COUNT : INTEGER := MAX_LINE; COLUMN_SEPARATOR : STRING(1..3) := " | "; HEADER : STRING(1..MAX_STRING); TABLE_WIDTH : NATURAL; SOURCE_FILE : FILE_TYPE; TAB_FILE : FILE_TYPE; FILE_LIST : DYNAMIC_STRING; FNAME : DYNAMIC_STRING; TOKEN : DYNAMIC_STRING; FILENAME : STRING(1..MAX_STRING); SEPARATOR : CHARACTER; LINE : STRING(1..MAX_STRING); LAST : INTEGER; FILE_LENGTH : INTEGER; GLOBAL_ERROR : exception; BLANKS : constant STRING(1..MAX_COLUMN) := " "& " "; HEADER_BAR : constant STRING(1..MAX_COLUMN) := "============================================================================"& "============================================================================"; procedure WRITE_ERROR (PART1 : in STRING; PART2 : in STRING) is begin NEW_LINE; PUT("**ERROR**"); PUT(PART1); PUT(PART2); NEW_LINE; end WRITE_ERROR; procedure OPEN_CO is TAB_NAME : STRING(1..MAX_STRING); begin NEW_LINE; PUT("ENTER TABLE_FILE_NAME =>"); GET_LINE(TAB_NAME, LAST); CREATE(TAB_FILE, OUT_FILE, TAB_NAME(1..LAST)); end; function FILE_NAME_LINE return BOOLEAN is begin if LAST >= 10 and then (LINE(1..10) = "::::::::::" or LINE(1..10) = "--::::::::")then return TRUE; else return FALSE; end if; end FILE_NAME_LINE; procedure READ_SUBFILE_HEADER( PRINT_FLAG: BOOLEAN := TRUE) is begin GET_LINE(SOURCE_FILE, LINE, LAST); if PRINT_FLAG then PUT("::"); PUT_LINE(LINE(1..LAST)); end if; --Skip over the trailing ":::::::::::::" line GET_LINE(SOURCE_FILE, LINE, LAST); end READ_SUBFILE_HEADER; procedure PUT_DYNAMIC (STR : in out DYNAMIC_STRING; LINE : in out STRING) is POS : NATURAL; CHAR : CHARACTER; STR_LEN : NATURAL; begin begin --guard for END_OF_STRING STR_LEN := LINE'LENGTH; --Delete leading blanks READ(CHAR, STR); while CHAR = ' ' loop DELETE_CHAR(STR); READ(CHAR,STR); end loop; -- remove partial words from the tail READ(CHAR, STR_LEN+1, STR); while CHAR /= ' ' loop READ(CHAR, STR_LEN, STR); STR_LEN := STR_LEN - 1; exit when STR_LEN = 0; end loop; exception when END_OF_STRING => null; --This exception should occur only when the --dynamic string is shorter than the output --line. Since, then the first READ is beyond --the string. At this point, STR_LEN is --properly set. end; --guard for END_OF_STRING --Make sure that a word which is longer than the field width is split --across multiple lines if STR_LEN = 0 then STR_LEN := LINE'LENGTH; end if; begin --Guard for END_OF_STRING --Transfer the appropriate text POS := 0; for I in 1..STR_LEN loop READ(CHAR, STR); LINE(I) := CHAR; DELETE_CHAR(STR); POS := I; end loop; exception when END_OF_STRING => null; end; --Guard for END_OF_STRING --Pad the string with blanks when it is not completely filled for I in POS+1..LINE'LENGTH loop LINE(I) := ' '; end loop; end PUT_DYNAMIC; procedure GET_LIST_OF_FILENAMES is TAB_TEMP : FILE_TYPE; COMMAND : STRING(1..MAX_STRING); D_COMMAND : DYNAMIC_STRING; -- This procedure prompts the user for a filename search pattern, -- builds a command to place a list of valid filenames in a file, and -- then reads that file building a dynamic string of files to be -- scanned. It calls the system dependent routine HOST.EXECUTE_CMDS -- and also builds a system dependent string wich is passed as the -- command to be executed. -->>>>>>>>>>>>>>>>>>>>>>>S Y S T E M D E P E N D E N T<<<<<<<<<<<<<<<-- begin ASSIGN(FILE_LIST, EMPTY_STR); PUT("ENTER NAMES OF FILES TO BE SCANNED => "); GET_LINE(LINE, LAST); COMMAND(1..3) := "ls "; COMMAND(4..LAST+3) := LINE(1..LAST); COMMAND(LAST+4..LAST+21) := " >> CREATE_CO.TEMP"; begin --build file list CONVERT_TO_DYNAMIC(COMMAND(1..LAST+21), D_COMMAND); HOST.EXECUTE_CMDS(D_COMMAND); OPEN(TAB_TEMP, IN_FILE, "CREATE_CO.TEMP"); loop --Until end of file GET_LINE(TAB_TEMP, LINE, LAST); APPEND(" ", FILE_LIST); APPEND(LINE(1..LAST), FILE_LIST); end loop; exception when HOST.EXECUTION_ERROR => PUT_LINE("**ERROR** NO FILES FOUND"); DELETE(TAB_TEMP); when END_ERROR => DELETE(TAB_TEMP); --End of file expected. end; end GET_LIST_OF_FILENAMES; function VALUE(STR : in STRING) return NATURAL is TOTAL : NATURAL; begin TOTAL := 0; for I in 1..STR'LENGTH loop TOTAL := TOTAL*10; case STR(I) is when '0' => TOTAL := TOTAL+0; when '1' => TOTAL := TOTAL+1; when '2' => TOTAL := TOTAL+2; when '3' => TOTAL := TOTAL+3; when '4' => TOTAL := TOTAL+4; when '5' => TOTAL := TOTAL+5; when '6' => TOTAL := TOTAL+6; when '7' => TOTAL := TOTAL+7; when '8' => TOTAL := TOTAL+8; when '9' => TOTAL := TOTAL+9; when others => raise CONSTRAINT_ERROR; end case; end loop; return TOTAL; end VALUE; procedure READ_SET_UP is SELECTOR : STRING(1..MAX_STRING); D_SELECTOR : DYNAMIC_STRING; ID : STRING(1..MAX_ID); LEN : STRING(1..10); begin PUT("ENTER FIELD SELECTOR =>"); GET_LINE(SELECTOR, LAST); CONVERT_TO_DYNAMIC(SELECTOR(1..LAST), D_SELECTOR); NUMBER_OF_FIELDS := 0; while not EMPTY(D_SELECTOR) loop --Extract FIELD_ID GET_TOKEN(D_SELECTOR, TOKEN, SEPARATOR); if SEPARATOR = ';' then OPTION_SPACES :=TRUE; elsif SEPARATOR = ':' then OPTION_BAR := TRUE; end if; if LENGTH(TOKEN) > MAX_ID then CONVERT_TO_STRING(TOKEN, ID); WRITE_ERROR("--ILLEGAL FIELD_ID: ", ID); raise GLOBAL_ERROR; else ID := BLANKS(1..MAX_ID); CONVERT_TO_STRING(TOKEN, ID); while ID(MAX_ID) = ' ' loop ID(2..MAX_ID) := ID(1..MAX_ID-1); ID(1) := ' '; end loop; end if; --Extract FIELD_LEN GET_TOKEN(D_SELECTOR, TOKEN, SEPARATOR); CONVERT_TO_STRING(TOKEN, LEN); --Store into selector descriptor table NUMBER_OF_FIELDS := NUMBER_OF_FIELDS+1; FIELD_ID (NUMBER_OF_FIELDS) := ID; FIELD_LEN(NUMBER_OF_FIELDS) := VALUE(LEN(1..LENGTH(TOKEN))); end loop; exception when CONSTRAINT_ERROR => WRITE_ERROR("--ILLEGAL FIELD_SIZE: ", LEN(1..LENGTH(TOKEN))); raise GLOBAL_ERROR; when END_OF_STRING => WRITE_ERROR("--ILLEGAL SELECTOR FORMAT: ", SELECTOR(1..LAST)); end READ_SET_UP; procedure BUILD_HEADER (FILENAME : in STRING) is HEADER_FIELD : array(1..MAX_NUMBER_OF_FIELDS) of STRING(1..MAX_STRING); HEADER_SIZE : array(1..MAX_NUMBER_OF_FIELDS) of NATURAL; POS : NATURAL; POS_START : NATURAL; HEAD : NATURAL; MID : NATURAL; TAIL : NATURAL; PAGED_FILE : BOOLEAN := FALSE; begin begin --process a file OPEN(SOURCE_FILE, IN_FILE, FILENAME); PROCESS_A_FILE: loop GET_LINE(SOURCE_FILE, LINE, LAST); if LAST >= MAX_ID then for I in 1..NUMBER_OF_FIELDS loop --Check for subfile header in a paged file so that only one --subfile is read to create the header. if FILE_NAME_LINE then if PAGED_FILE then exit; else PAGED_FILE := TRUE; READ_SUBFILE_HEADER(FALSE); end if; end if; if LINE(1..MAX_ID) = FIELD_ID(I) then POS := MAX_ID+1; while LINE(POS) = ' ' loop POS := POS+1; end loop; POS_START := POS; for J in POS..LAST loop exit when LINE( J ) = ':'; POS := J; end loop; HEADER_SIZE (I) := POS - POS_START + 1; HEADER_FIELD(I)(1..HEADER_SIZE(I)) := LINE(POS_START..POS); exit; end if; end loop; end if; end loop PROCESS_A_FILE; exception when END_ERROR => CLOSE(SOURCE_FILE); when NAME_ERROR=> WRITE_ERROR("ABORTED, FIRST FILE IS NOT ACCESSIBLE", FILENAME); raise GLOBAL_ERROR; end; --process a file --Now build the header line, centering or truncating each header field --as necessary. POS := 0; for I in 1..NUMBER_OF_FIELDS loop if HEADER_SIZE(I) >= FIELD_LEN(I) then HEADER(POS+1..POS+FIELD_LEN(I)) := HEADER_FIELD(I)(1..FIELD_LEN(I)); POS := POS+FIELD_LEN(I); else HEAD := (FIELD_LEN(I) - HEADER_SIZE(I) + 1)/2; TAIL := (FIELD_LEN(I) - HEADER_SIZE(I) - HEAD); MID := HEADER_SIZE(I); HEADER(POS+1..POS+HEAD) := BLANKS(1..HEAD); POS := POS+HEAD; HEADER(POS+1..POS+MID ) := HEADER_FIELD(I)(1..MID); POS := POS+MID ; HEADER(POS+1..POS+TAIL) := BLANKS(1..TAIL); POS := POS+TAIL; end if; HEADER(POS+1..POS+3) := COLUMN_SEPARATOR; POS := POS+3; end loop; TABLE_WIDTH := POS-1; PUT("THE TABLE WIDTH IS CALCULATED TO BE: "); PUT(POS,3); NEW_LINE; if TABLE_WIDTH > MAX_COLUMN then raise GLOBAL_ERROR; end if; end BUILD_HEADER; procedure SAVE_FIELD (I : in POSITIVE) is J : POSITIVE; begin --Skip title J := 1; while LINE(J) /= ':' loop J := J+1; end loop; --Skip leading blanks if J < LAST then J := J+1; while LINE(J) = ' ' loop exit when J = LAST; J := J+1; end loop; LINE(1..LAST-J+1) := LINE(J..LAST); CONVERT_TO_DYNAMIC(LINE(1..LAST-J+1), FIELD_STR(I)); end if; --Read continuation lines GET_LINE(SOURCE_FILE, LINE, LAST); while LINE(1..MAX_ID) = BLANKS(1..MAX_ID) loop J := 1; while LINE(J) = ' ' loop J := J + 1; exit when J=LAST; end loop; APPEND( " ", FIELD_STR(I)); LINE(1..LAST-J+1) := LINE(J..LAST); APPEND(LINE(1..LAST-J+1), FIELD_STR(I)); GET_LINE(SOURCE_FILE, LINE, LAST); end loop; end SAVE_FIELD; procedure PUT_GRAPH_ENTRY is ALL_EMPTY : BOOLEAN; OUT_LINE : STRING(1..MAX_STRING); begin loop ALL_EMPTY := TRUE; for I in 1..NUMBER_OF_FIELDS loop if not EMPTY(FIELD_STR(I)) then ALL_EMPTY := FALSE; exit; end if; end loop; exit when ALL_EMPTY; if LINE_COUNT >= MAX_LINE then NEW_PAGE(TAB_FILE); LINE_COUNT := 3; PUT_LINE(TAB_FILE, HEADER_BAR(1..TABLE_WIDTH)); PUT_LINE(TAB_FILE, HEADER (1..TABLE_WIDTH)); PUT_LINE(TAB_FILE, HEADER_BAR(1..TABLE_WIDTH)); else NEW_LINE(TAB_FILE); end if; LINE_COUNT := LINE_COUNT+1; for I in 1..NUMBER_OF_FIELDS loop PUT_DYNAMIC(FIELD_STR(I), OUT_LINE(1..FIELD_LEN(I))); PUT(TAB_FILE, OUT_LINE(1..FIELD_LEN(I))); PUT(TAB_FILE,COLUMN_SEPARATOR); end loop; end loop; end PUT_GRAPH_ENTRY; procedure PUT_END_OF_ENTRY is begin if OPTION_SPACES then NEW_LINE(TAB_FILE); LINE_COUNT := LINE_COUNT+1; end if; if OPTION_BAR then NEW_LINE(TAB_FILE); PUT(TAB_FILE, HEADER_BAR(1..TABLE_WIDTH)); LINE_COUNT := LINE_COUNT+1; end if; if OPTION_SPACES then NEW_LINE(TAB_FILE); LINE_COUNT := LINE_COUNT+1; end if; end PUT_END_OF_ENTRY; begin --Prompt user for co_file name. Then get list of files to be processed --and added to the co_file. PUT_LINE(" CREATE_TB VERSION 850121"); OPEN_CO; READ_SET_UP; GET_LIST_OF_FILENAMES; GET_TOKEN(FILE_LIST, FNAME, SEPARATOR); CONVERT_TO_STRING(FNAME, FILENAME); FILE_LENGTH := LENGTH(FNAME); BUILD_HEADER(FILENAME(1..FILE_LENGTH)); while not EMPTY( FNAME ) loop CONVERT_TO_STRING(FNAME, FILENAME); FILE_LENGTH := LENGTH(FNAME); PUT_LINE( FILENAME(1..FILE_LENGTH) ); begin -- Protect for illegal files OPEN( SOURCE_FILE, IN_FILE, FILENAME(1..LENGTH(FNAME)) ); --Check for subfile in a PAGED file GET_LINE(SOURCE_FILE, LINE, LAST); if FILE_NAME_LINE then READ_SUBFILE_HEADER(TRUE); GET_LINE(SOURCE_FILE, LINE, LAST); end if; begin --process a file PROCESS_A_FILE: loop LINE_IGNORED := TRUE; --Check for subfile in a PAGED file if FILE_NAME_LINE then PUT_GRAPH_ENTRY; PUT_END_OF_ENTRY; READ_SUBFILE_HEADER(TRUE); end if; for I in 1..NUMBER_OF_FIELDS loop if LINE(1..MAX_ID) = FIELD_ID(I) then SAVE_FIELD(I); LINE_IGNORED := FALSE; exit; end if; end loop; --SAVE_FIELD always reads an extra line. Therefore, only read another --line if this line was ignored. if LINE_IGNORED then GET_LINE(SOURCE_FILE, LINE, LAST); end if; end loop PROCESS_A_FILE; exception when END_ERROR => CLOSE(SOURCE_FILE); PUT_GRAPH_ENTRY; PUT_END_OF_ENTRY; end; --process a file GET_TOKEN(FILE_LIST, FNAME, SEPARATOR); exception when NAME_ERROR=> NEW_LINE; PUT("**ERROR** FILE:"); PUT(FILENAME(1..FILE_LENGTH)); PUT_LINE("CAN'T BE OPENED."); GET_TOKEN(FILE_LIST, FNAME, SEPARATOR); end; -- Protect for illegal files end loop; exception -- END_OF_STRING may be raised by a call to GET_TOKEN in an attempt to get -- another file name after the last name in the list has been read. when END_OF_STRING | GLOBAL_ERROR => CLOSE(TAB_FILE); end CREATE_TABLE; :::::::::::::: environs.text :::::::::::::: package ENVIRONS is ERROR : exception; -->>>>>>>>>>>>>>>>>>>C O N S T A N T D E C L A R A T I O N S<<<<<<<<<<<<<<<-- CONTINUATION : constant CHARACTER := '\'; COMMENT : constant CHARACTER := '-'; TARGET_LIST_TERMINATOR : constant CHARACTER := ':'; DEPENDENT_LIST_TERMINATOR : constant CHARACTER := ';'; MAX_LINE_LENGTH : constant INTEGER := 80; MAX_CMD_LENGTH : constant INTEGER := 200; MAX_FILENAME_LENGTH : constant INTEGER := 14; END_OF_COMMANDS : constant CHARACTER := '$'; FIRST_CHAR_OF_ENTRY_NAME : constant CHARACTER := '%'; -->>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<-- end ENVIRONS; :::::::::::::: host.text :::::::::::::: with STR_PACK; with CALENDAR; package HOST is function MODIFICATION_TIMESTAMP (FOR_DBO : STR_PACK.DYNAMIC_STRING) return CALENDAR.TIME; ACCESSIBILITY_ERROR : exception; function ARGS_EXIST return BOOLEAN; procedure EXECUTE_CMDS (CMD_LIST : in STR_PACK.DYNAMIC_STRING); EXECUTION_ERROR : EXCEPTION; end HOST; with HOST_LCD_IF; with UNIX_CALL; with SYSTEM; with UNCHECKED_CONVERSION; with ENVIRONS; package body HOST is function MODIFICATION_TIMESTAMP (FOR_DBO : STR_PACK.DYNAMIC_STRING) return CALENDAR.TIME is GET_TIME : constant UNIX_CALL.CALL := 666; NAME_LENGTH : INTEGER; function ADDR_TO_INT is new UNCHECKED_CONVERSION (SYSTEM.ADDRESS, LONG_INTEGER); TIMESTAMP : CALENDAR.TIME; RSLT : UNIX_CALL.RESULT; FILENAME : STRING(1 .. ENVIRONS.MAX_FILENAME_LENGTH); begin STR_PACK.CONVERT_TO_STRING (FOR_DBO, FILENAME); NAME_LENGTH := STR_PACK.LENGTH (FOR_DBO); if NAME_LENGTH < 14 then FILENAME (NAME_LENGTH + 1) := ASCII.NUL; end if; RSLT := UNIX_CALL.SYSCALL1 (GET_TIME, ADDR_TO_INT(FILENAME'address)); if (RSLT = -1) then raise ACCESSIBILITY_ERROR; end if; TIMESTAMP := RSLT; -- This may become less trivial when CALENDAR -- changes ( and Time /= Long_Integer!) return (TIMESTAMP); end MODIFICATION_TIMESTAMP; function ARGS_EXIST return BOOLEAN is PARMS : STRING(1 .. 100); PARM_COUNT : INTEGER; begin HOST_LCD_IF.PARAM_STRING (PARMS, PARM_COUNT); return (PARM_COUNT > 0); end ARGS_EXIST; procedure EXECUTE_CMDS (CMD_LIST : in STR_PACK.DYNAMIC_STRING) is RET_CODE : UNIX_CALL.RESULT; INVOKE : constant UNIX_CALL.CALL := 667; STR_BUFFER : STRING(1 .. ENVIRONS.MAX_CMD_LENGTH); function ADDR_TO_INT is new UNCHECKED_CONVERSION (SYSTEM.ADDRESS, LONG_INTEGER); begin for I in STR_BUFFER'range loop STR_BUFFER(I) := ' '; end loop; STR_PACK.CONVERT_TO_STRING (CMD_LIST, STR_BUFFER); RET_CODE := UNIX_CALL.SYSCALL1 (INVOKE, ADDR_TO_INT(STR_BUFFER'address)); if (RET_CODE /= 0) then raise EXECUTION_ERROR; end if; end EXECUTE_CMDS; end HOST; :::::::::::::: str_pack.text :::::::::::::: -- This package defines and maintains dynamic strings that are used -- by the other packages and the procedure CONSTRUCT. package STR_PACK is -- Each variable of this type is composed of a sequence of -- characters and an indication of the number of characters in the -- sequence (i.e., its length >= 0). Each character in the sequence -- is ordered relative to its position, where the first character -- has position l, and the position of each character thereafter is -- incremented by l. If there are no characters in the sequence, -- then the length is 0, else the length is the position of the -- last character in the sequence. Initially, a variable of this -- type is an empty string (i.e., its length is zero). type DYNAMIC_STRING is limited private; -- This constant represents an empty string (i.e., its length is -- zero and thus contains no characters). -- EMPTY_STR : constant DYNAMIC_STRING; -- Deferred constants not yet implemented so a function is used. function EMPTY_STR return DYNAMIC_STRING; procedure ASSIGN (STR : in out DYNAMIC_STRING; D_STRING : in DYNAMIC_STRING); procedure CONVERT_TO_DYNAMIC (CHAR_STRING : in STRING; STR : in out DYNAMIC_STRING); procedure DELETE_CHAR (STR : in out DYNAMIC_STRING); procedure APPEND (CHAR : in CHARACTER; STR : in out DYNAMIC_STRING); procedure APPEND (CHAR_STRING : in STRING; STR : in out DYNAMIC_STRING); procedure APPEND (D_STRING : in DYNAMIC_STRING; STR : in out DYNAMIC_STRING); procedure CONVERT_TO_STRING (STR : in DYNAMIC_STRING; CH_STR : out STRING); procedure SET_TOKEN_STREAM (LINE : in STRING); procedure GET_TOKEN (TOKEN : in out DYNAMIC_STRING; SEPARATOR : in out CHARACTER); procedure RETURN_TOKEN; procedure GET_TOKEN (STR : in out DYNAMIC_STRING; TOKEN : out DYNAMIC_STRING; SEPARATOR: out CHARACTER); function LENGTH (STR : in DYNAMIC_STRING) return NATURAL; procedure READ (CHAR : out CHARACTER; STR : in DYNAMIC_STRING); procedure READ (CHAR : out CHARACTER; ITH : in POSITIVE; STR : in DYNAMIC_STRING); function EMPTY(STR: DYNAMIC_STRING) return BOOLEAN; function "=" (LEFT : DYNAMIC_STRING; RIGHT : DYNAMIC_STRING) return BOOLEAN; procedure DUMP (TITLE : in STRING; STR : in DYNAMIC_STRING); function NUM_OF_TOKENS (DYN_STR : DYNAMIC_STRING) return NATURAL; END_OF_STRING : exception; private -- Each dynamic string is decomposed into segments which are at -- most SEGMENT_SIZE characters in length. The head and tail -- segments may be partial(i.e. less than SEGMENT_SIZE), but all -- middle segments must be a full SEGMENT_SIZE in length. SEGMENT_SIZE : constant INTEGER := 10; BLANKS : CONSTANT STRING (1..SEGMENT_SIZE) := " "; type STR_REC; type STR_SEGMENT is access STR_REC; -- This data structure defines a segment of a dynamic string as -- follows: -- ( i) STR contains this part of the string -- ( ii) NEXT_SEGMENT points to the next segment in the -- dynamic string. -- (iii) PRIOR_SEGMENT points to the previous segment in the -- dynamic string. --====================================================================== --Note that the procedures RESET, ASSIGN, and APPEND have been written --so that when a new value is assigned to a dynamic string already --allocated segment blocks are kept in the linked list even though they --are not currently in use. Depending on the storage manager, this --approach may need modification. Modification will also be required if --new strings are created using ADD rather than APPEND. type STR_REC is record -- SEGMENT : STRING (1..SEGMENT_SIZE) := (1..SEGMENT_SIZE => ' '); -- Packed aggregates are not yet implemented. Array must be -- initialized with string of spaces. SEGMENT : STRING (1..SEGMENT_SIZE) := " "; NEXT_SEGMENT : STR_SEGMENT; PRIOR_SEGMENT: STR_SEGMENT; end record; -- This data structure defines a dynamic string that is composed -- of a linked list of segments that are ordered from HEAD to TAIL. -- NUM_CHAR indicates the length of the dynamic string (i.e., the -- sum of the lengths of all segments of which it is composed). -- FIRST is the position within the head segment of the first -- character. LAST is the position within the tail segment of the -- last character. type DYNAMIC_STRING is record HEAD : STR_SEGMENT := null; TAIL : STR_SEGMENT := null; NUM_CHAR : NATURAL :=0; FIRST : NATURAL :=0; LAST : NATURAL :=0; end record; end STR_PACK; with TEXT_IO; use TEXT_IO, INTEGER_IO; with SYSTEM; package body STR_PACK is TOKEN_STREAM : DYNAMIC_STRING; PSEUDO_TOKEN_STREAM : DYNAMIC_STRING; OLD_TOKEN_HEAD : STR_SEGMENT; OLD_TOKEN_FIRST : NATURAL; OLD_TOKEN_NUM_CHAR : NATURAL; -- A token stream is useful to conserve heap space when a file is being -- processed as a sequence of dynamic strings. By having two pointers -- to the same dynamic string(aliasing) the same space may be used for -- the next dynamic string after breaking the first one into tokens. A -- special TOKEN procedure must be used in conjunction with SET_TOKEN_STREAM. -- That TOKEN procedure doesn't have a dynamic string for input and thus uses. -- PSEUDO_TOKEN_STREAM. procedure SET_TOKEN_STREAM (LINE : in STRING) is begin CONVERT_TO_DYNAMIC(LINE, TOKEN_STREAM); PSEUDO_TOKEN_STREAM := TOKEN_STREAM; OLD_TOKEN_HEAD := PSEUDO_TOKEN_STREAM.HEAD; OLD_TOKEN_FIRST := PSEUDO_TOKEN_STREAM.FIRST; OLD_TOKEN_NUM_CHAR := PSEUDO_TOKEN_STREAM.NUM_CHAR; end SET_TOKEN_STREAM; -- This GET_TOKEN procedure may only be used in conjunction with -- SET_TOKEN_STREAM. This procedure extracts a token from the -- PSEUDO_TOKEN_STREAM. It also makes an additional check to convert -- the standard GET_TOKEN's "end of string marker ; " to an 'E' so that -- Ada syntax may be properly analyzed. procedure GET_TOKEN (TOKEN : in out DYNAMIC_STRING; SEPARATOR : in out CHARACTER) is begin OLD_TOKEN_HEAD := PSEUDO_TOKEN_STREAM.HEAD; OLD_TOKEN_FIRST := PSEUDO_TOKEN_STREAM.FIRST; OLD_TOKEN_NUM_CHAR := PSEUDO_TOKEN_STREAM.NUM_CHAR; GET_TOKEN(PSEUDO_TOKEN_STREAM, TOKEN, SEPARATOR); if SEPARATOR = ';' and then LENGTH(PSEUDO_TOKEN_STREAM) = 0 and then TOKEN_STREAM.TAIL.SEGMENT(TOKEN_STREAM.LAST) /= ';' and then TOKEN_STREAM.TAIL.SEGMENT(TOKEN_STREAM.LAST) /= ' ' then SEPARATOR := 'E'; end if; end GET_TOKEN; -- This procedure resets the pointers to the token stream so that the most -- recently obtained token is reinstated at the head of the stream. procedure RETURN_TOKEN is begin PSEUDO_TOKEN_STREAM.HEAD := OLD_TOKEN_HEAD; PSEUDO_TOKEN_STREAM.FIRST := OLD_TOKEN_FIRST; PSEUDO_TOKEN_STREAM.NUM_CHAR := OLD_TOKEN_NUM_CHAR; end RETURN_TOKEN; -- The is a debugging procedure which prints out a complete dynamic string, -- including its header information as well as all allocated space. procedure DUMP (TITLE : in STRING; STR : in DYNAMIC_STRING) is CURRENT : STR_SEGMENT; COUNT : INTEGER; begin NEW_LINE; PUT(TITLE); PUT(STR.NUM_CHAR,5); PUT(STR.FIRST,5); PUT(STR.LAST,5); CURRENT := STR.HEAD; while CURRENT /= null loop PUT(CURRENT.SEGMENT); CURRENT := CURRENT.NEXT_SEGMENT; COUNT := COUNT+1; if COUNT = 5 then NEW_LINE; COUNT := 0; end if; end loop; NEW_LINE; end DUMP; -- This function returns an empty string value for the private type -- DYNAMIC_STRING. function EMPTY_STR return DYNAMIC_STRING is STR : DYNAMIC_STRING; begin return STR; end EMPTY_STR; -- This function returns TRUE if the number of characters in a dynamic -- string is zero. FALSE, otherwise. function EMPTY(STR: DYNAMIC_STRING) return BOOLEAN is begin return STR.NUM_CHAR = 0; end EMPTY; -- This procedure resets a DYNAMIC_STRING to the empty value. However, the -- HEAD pointer is left pointing to the linked list of segments so that the -- space may be reused. procedure RESET(STR : in out DYNAMIC_STRING) is begin STR.NUM_CHAR:= 0; STR.FIRST := 0; STR.LAST := 0; STR.TAIL := STR.HEAD; end RESET; -- This procedure returns the lead character in a dynamic string. The -- character is not deleted. The END_OF_STRING exception is returned -- if the dynamic string is empty. procedure READ(CHAR : out CHARACTER; STR : in DYNAMIC_STRING) is begin if STR.NUM_CHAR = 0 then raise END_OF_STRING; else CHAR := STR.HEAD.SEGMENT(STR.FIRST); end if; end READ; -- This function returns the number of characters in a dynamic string, not -- the amount of allocated space. function LENGTH (STR : in DYNAMIC_STRING) return NATURAL is begin return STR.NUM_CHAR; end; -- This procedure assigns the value of one dynamic string to another. It -- does not merely copy the pointer values since thsi would result in -- undesirable aliasing. Each segment is copied in its entirety without -- realigning characters across the segments. procedure ASSIGN (STR : in out DYNAMIC_STRING; D_STRING: in DYNAMIC_STRING) is CURRENT_SEGMENT : STR_SEGMENT; OLD_SEGMENT : STR_SEGMENT; NEW_SEGMENT : STR_SEGMENT; begin --First check for the empty string. RESET(STR); if D_STRING.NUM_CHAR = 0 then --String is empty. We are all done. return; end if; --If the string was not empty, copy its contents over to STR. --First, set the dynamic string fields and copy over the complete --contents of D_STRING.HEAD. This way the null NEXT and PRIOR_ --SEGMENT pointers are captured for one segment strings. Note we --must be carefull always to create new segments and never to --point to segments from D_STRING. STR.FIRST := D_STRING.FIRST; STR.LAST := D_STRING.LAST; STR.NUM_CHAR := D_STRING.NUM_CHAR; if STR.HEAD = null then STR.HEAD := new STR_REC; end if; STR.HEAD.SEGMENT := D_STRING.HEAD.SEGMENT; -- Now copy over any middle segments. CURRENT_SEGMENT := STR.HEAD; OLD_SEGMENT := D_STRING.HEAD; while OLD_SEGMENT /= D_STRING.TAIL loop OLD_SEGMENT := OLD_SEGMENT.NEXT_SEGMENT; if CURRENT_SEGMENT.NEXT_SEGMENT = null then NEW_SEGMENT := new STR_REC; CURRENT_SEGMENT.NEXT_SEGMENT := NEW_SEGMENT; NEW_SEGMENT.PRIOR_SEGMENT := CURRENT_SEGMENT; else NEW_SEGMENT := CURRENT_SEGMENT.NEXT_SEGMENT; end if; NEW_SEGMENT.SEGMENT := OLD_SEGMENT.SEGMENT; CURRENT_SEGMENT := NEW_SEGMENT; end loop; --Since the contents of tail have been copied over already, merely --point TAIL to the current segment. STR.TAIL := CURRENT_SEGMENT; end ASSIGN; -- This procedure removes the first character in a dynamic string, reducing -- by one thelength of the string. When the HEAD segment is emptied the HEAD -- pointer is moved and the space for that segment may be returned to the -- heap. procedure DELETE_CHAR (STR : in out DYNAMIC_STRING) is begin if STR.NUM_CHAR = 0 then raise END_OF_STRING; else --Delete the first character and see if the head segment has become --empty. STR.NUM_CHAR := STR.NUM_CHAR-1; if STR.FIRST < SEGMENT_SIZE then STR.FIRST := STR.FIRST+1; else --Remove this head segment. STR.HEAD := STR.HEAD.NEXT_SEGMENT; STR.FIRST:= 1; end if; --Now check for an empty string and clean up just in case. if STR.NUM_CHAR = 0 then STR.HEAD := null; STR.TAIL := null; STR.FIRST:= 0; STR.LAST := 0; end if; end if; end DELETE_CHAR; -- This procedure moves characters from the dynamic string to the output -- string. The number of characters moved is the minimum of the two string -- lengths. The dynamic is not modified by this procedure. procedure CONVERT_TO_STRING (STR : in DYNAMIC_STRING; CH_STR : out STRING ) is SIZE : NATURAL; POS : NATURAL; CURRENT_SEGMENT : STR_SEGMENT; begin if CH_STR'LENGTH > STR.NUM_CHAR then SIZE := STR.NUM_CHAR; else SIZE := CH_STR'LENGTH; end if; if SIZE = 0 then return; elsif SIZE <= SEGMENT_SIZE-STR.FIRST+1 then --Requested string is completely within the head segment. CH_STR(1..SIZE) := STR.HEAD.SEGMENT(STR.FIRST..STR.FIRST+SIZE-1); else --Requested string is split across several segments --Get head segment. POS := SEGMENT_SIZE-STR.FIRST+1; CH_STR(1..POS) := STR.HEAD.SEGMENT(STR.FIRST..SEGMENT_SIZE); --Copy over the middle segments in their entirety. CURRENT_SEGMENT := STR.HEAD.NEXT_SEGMENT; while POS+(SEGMENT_SIZE) <= SIZE loop CH_STR(POS+1..POS+(SEGMENT_SIZE)) := CURRENT_SEGMENT.SEGMENT; CURRENT_SEGMENT := CURRENT_SEGMENT.NEXT_SEGMENT; POS := POS + SEGMENT_SIZE; end loop; --Get tailing segment, if necessary. if POS < SIZE then CH_STR(POS+1..SIZE) := CURRENT_SEGMENT.SEGMENT(1..SIZE-POS); end if; end if; end CONVERT_TO_STRING; -- This function is used to check for separators which are two characters in -- in length. A true value is returned only if the 1st two characters of the -- dynamic string match the two character parameters. The dynamic string is -- not modified. function LOOKAHEAD(STR: DYNAMIC_STRING; FIRST_CH: CHARACTER; NEXT_CH : CHARACTER) return boolean is begin if STR.NUM_CHAR <= 1 then return FALSE; elsif STR.HEAD.SEGMENT(STR.FIRST) /= FIRST_CH then return FALSE; else if STR.FIRST /= SEGMENT_SIZE then return STR.HEAD.SEGMENT(STR.FIRST+1) = NEXT_CH; else return STR.HEAD.NEXT_SEGMENT.SEGMENT(1) = NEXT_CH; end if; end if; end LOOKAHEAD; -- This procedure reads the Ith character within a dynamic string, where -- 0 < I <= LENGTH(string). If I <= 0, a constraint error is raised; if -- I > LENGTH(string) an END_OF_STRING error is raised. The dynamic -- string is unmodified. procedure READ (CHAR : out CHARACTER; ITH : in POSITIVE; STR : in DYNAMIC_STRING) is POS : NATURAL; CURRENT_SEGMENT : STR_SEGMENT; begin if ITH > STR.NUM_CHAR then raise END_OF_STRING; elsif ITH <= SEGMENT_SIZE - STR.FIRST + 1 then --The character is positioned within the head segment so --retrieval is immediate. CHAR := STR.HEAD.SEGMENT( STR.FIRST+ITH-1 ); else --The character is positioned in a segment other than the --head so the correct segment must be found prior to retrieval. POS := ITH - (SEGMENT_SIZE-STR.FIRST+1); CURRENT_SEGMENT := STR.HEAD.NEXT_SEGMENT; while POS > SEGMENT_SIZE loop POS := POS - SEGMENT_SIZE; CURRENT_SEGMENT := CURRENT_SEGMENT.NEXT_SEGMENT; end loop; CHAR := CURRENT_SEGMENT.SEGMENT(POS); end if; end READ; -- This function compares two dynamic strings on a character by character -- basis. Truth is returned only if the two string are of equal length -- and characters at each position are equal. function "=" (LEFT : DYNAMIC_STRING; RIGHT : DYNAMIC_STRING) return BOOLEAN is LEFT_CHAR : CHARACTER; RIGHT_CHAR : CHARACTER; begin if LEFT.NUM_CHAR = RIGHT.NUM_CHAR then for I in 1..LEFT.NUM_CHAR loop READ(LEFT_CHAR, I, LEFT); READ(RIGHT_CHAR,I, RIGHT); if LEFT_CHAR /= RIGHT_CHAR then return FALSE; end if; end loop; return TRUE; else return FALSE; end if; end "="; -- This procedure adds a character to the end of a dynamic string, allocating -- a new segment when necessary. procedure APPEND (CHAR : in CHARACTER; STR : in out DYNAMIC_STRING) is OLD_TAIL : STR_SEGMENT; begin if STR.NUM_CHAR = 0 then --This is a null string. Allocate one segment and insert a --character. if STR.HEAD = null then STR.HEAD := new STR_REC; end if; STR.TAIL := STR.HEAD; STR.FIRST:= 1; STR.LAST := 1; STR.HEAD.SEGMENT := BLANKS; STR.HEAD.SEGMENT(1) := CHAR; elsif STR.LAST = SEGMENT_SIZE then --A new segment must be added to hold this character. OLD_TAIL := STR.TAIL; if STR.TAIL.NEXT_SEGMENT = null then STR.TAIL := new STR_REC; STR.TAIL.PRIOR_SEGMENT := OLD_TAIL; else STR.TAIL := STR.TAIL.NEXT_SEGMENT; end if; STR.TAIL.SEGMENT := BLANKS; STR.TAIL.SEGMENT(1) := CHAR; STR.LAST := 1; OLD_TAIL.NEXT_SEGMENT := STR.TAIL; else --There is room in this segment for the character. STR.LAST := STR.LAST+1; STR.TAIL.SEGMENT(STR.LAST) := CHAR; end if; STR.NUM_CHAR := STR.NUM_CHAR+1; end APPEND; -- This procedure uses the APPEND character procedure to add a character -- string to the end of a dynamic string. procedure APPEND (CHAR_STRING : in STRING; STR : in out DYNAMIC_STRING) is begin for I in 1..CHAR_STRING'LENGTH loop APPEND(CHAR_STRING(I), STR); end loop; end APPEND; -- This procedure uses the APPEND charater procedure to add one dynamic -- string to the end of another. Characters are appended one at a time. -- Only the string being appended to is modified. procedure APPEND (D_STRING : in DYNAMIC_STRING; STR : in out DYNAMIC_STRING) is CHAR : CHARACTER; begin for I in 1..D_STRING.NUM_CHAR loop READ(CHAR, I, D_STRING); APPEND(CHAR, STR); end loop; end APPEND; -- This procedure transfers the value of a character string to a dynamic -- string, replacing the original value of the dynamic string. procedure CONVERT_TO_DYNAMIC (CHAR_STRING : in STRING; STR : in out DYNAMIC_STRING) is begin RESET(STR); APPEND(CHAR_STRING, STR); end CONVERT_TO_DYNAMIC; -- This procedure removes a token from the front of a dynamic string and -- also removes the token's separator. Both the token and the separator -- are returned to the caller. The separators are " ();:\, ", blank, and -- the comment delimiter --. Extraneous blanks are ignored. A semicolon is -- returned as the separator when the token is terminated by the end of string -- An END_OF_STRING exception is raised only when the dynamic string from -- which the token is being extracted is already empty whe GET_TOKEN is called procedure GET_TOKEN (STR : in out DYNAMIC_STRING; TOKEN : out DYNAMIC_STRING; SEPARATOR: out CHARACTER) is CHAR : CHARACTER; begin RESET(TOKEN); if EMPTY(STR) then raise END_OF_STRING; end if; --Get the next token and protect against end of string. begin --First skip all leading blanks READ(CHAR, STR); while CHAR = ' ' loop DELETE_CHAR(STR); READ(CHAR, STR); end loop; --Now copy characters until a separator is found. while CHAR /= ' ' and CHAR /= ',' and CHAR /= ':' and CHAR /= '\' and CHAR /= ';' and CHAR /= ')' and CHAR /= '(' and not LOOKAHEAD(STR, '-', '-') loop APPEND(CHAR, TOKEN); DELETE_CHAR(STR); READ(CHAR, STR); end loop; --Gobble up the separator; SEPARATOR := CHAR; DELETE_CHAR(STR); if SEPARATOR = '-' then DELETE_CHAR(STR); else --Gobble up redundant blanks while not EMPTY(STR) loop READ(CHAR, STR); if CHAR = ' ' then DELETE_CHAR(STR); else exit; end if; end loop; if (SEPARATOR = ' ') and (CHAR = ',' or CHAR = ';' or CHAR = ')' or CHAR = '\' or CHAR = '(' or CHAR = ':') then SEPARATOR := CHAR; DELETE_CHAR(STR); end if; end if; exception when END_OF_STRING => SEPARATOR := ';'; --end of string is o.k. here. end; end GET_TOKEN; -- This function counts the number of non-empty tokens within a dynamic -- string. The string is unmodified. function NUM_OF_TOKENS (DYN_STR : DYNAMIC_STRING) return NATURAL is COUNT : NATURAL := 0; TEMP_STR, TOKEN : DYNAMIC_STRING; SEPARATOR : CHARACTER; begin ASSIGN(TEMP_STR, DYN_STR); loop GET_TOKEN(TEMP_STR, TOKEN, SEPARATOR); -- Raises exception at EOL. if not EMPTY(TOKEN) then COUNT := COUNT + 1; end if; end loop; exception when END_OF_STRING => return (COUNT); end; end STR_PACK; :::::::::::::: unpage.text :::::::::::::: with TEXT_IO; use TEXT_IO; procedure UNPAGE is MAX_STRING : constant INTEGER := 255; NEW_FILE : FILE_TYPE; PAGED_FILE : FILE_TYPE; LINE : STRING(1..MAX_STRING); LAST : INTEGER; procedure WRITE_ERROR (PART1 : in STRING; PART2 : in STRING) is begin NEW_LINE; PUT("**ERROR**"); PUT(PART1); PUT(PART2); NEW_LINE; end WRITE_ERROR; procedure OPEN_INPUT is TAB_NAME : STRING(1..MAX_STRING); begin NEW_LINE; PUT("ENTER NAME OF PAGE-CATENATED FILE =>"); GET_LINE(TAB_NAME, LAST); OPEN(PAGED_FILE, IN_FILE, TAB_NAME(1..LAST)); end; function FILE_NAME_LINE return BOOLEAN is begin if LAST >= 10 and then LINE(1..10) = "::::::::::" then return TRUE; else return FALSE; end if; end FILE_NAME_LINE; procedure OPEN_NEW_FILE is begin GET_LINE(PAGED_FILE, LINE, LAST); PUT_LINE(LINE(1..LAST)); if IS_OPEN(NEW_FILE) then CLOSE(NEW_FILE); end if; CREATE (NEW_FILE, OUT_FILE, LINE(1..LAST)); --Skip over the trailing ":::::::::::::" line GET_LINE(PAGED_FILE, LINE, LAST); end OPEN_NEW_FILE; begin --Prompt user for paged file name. Then get name of first file to be processed OPEN_INPUT; GET_LINE(PAGED_FILE, LINE, LAST); if FILE_NAME_LINE then OPEN_NEW_FILE; loop GET_LINE(PAGED_FILE, LINE, LAST); if FILE_NAME_LINE then CLOSE(NEW_FILE); OPEN_NEW_FILE; else PUT_LINE(NEW_FILE, LINE(1..LAST)); end if; end loop; else WRITE_ERROR("FILE IS NOT IN PAGED FORMAT, EXECUTION ABORTED", "."); end if; exception when END_ERROR => CLOSE(NEW_FILE); CLOSE(PAGED_FILE); end UNPAGE; 
