MODULE basic$env IDENT "V01-001" !++ ! !****************************************************************************** !* * !* © Copyright 1994 Hewlett-Packard Development Company, L.P. * !* * !* Confidential computer software. Valid license from HP required for * !* possession, use or copying. Consistent with FAR 12.211 and 12.212, * !* Commercial Computer Software, Computer Software Documentation, and * !* Technical Data for Commercial Items are licensed to the U.S. Government * !* under vendor's standard commercial license. * !* * !* HP shall not be liable for technical or editorial errors or omissions * !* contained herein. The information in this document is subject to change * !* without notice. * !* * !* The limited warranties for HP products are exclusively set forth in * !* the documentation accompanying such products. Nothing herein should be * !* construed as constituting a further or additional warranty. * !* * !****************************************************************************** ! ! ! FACILITY: ! Sample DEC Basic Environement Support ! ! ABSTRACT: ! Provide a sub-set of VAX Basic environment functions ! on OpenVMX AXP systems. ! ! ENVIRONMENT: ! Although targeted for use on OpenVMS AXP systems, these ! TPU procedures will work on any OpenVMS VAX system beyond ! version V6.0. ! ! AUTHOR: Brian J. McCarthy ! ! CREATION DATE: 28-MAR-1994 ! ! Usage: ! Intended to be used as a TPU command procedure, the following ! command should be used to activate this procedure. ! ! $ EDIT/TPU/NODISPLAY/NOSECTION/NOINI/COMMAND=BASIC$ENV.TPU - ! [/OUTPUT=FILE-SPEC] ! file-name1 [,file-name2...] ! ! If file names are present on the command line, the files are ! appended and sorted by BASIC line number then written out to ! either the first file name in the list or to the file ! specified by /output=FILE-SPEC. ! ! For example: ! !$ EDIT/TPU/NOSECTION/NOINI/NODISPLAY/COMMAND=BASIC$ENV.TPU file1.bas,file2.bas ! ! Would cause file1.bas to be sorted and then file2.bas appeneded to the end of ! it with the output being a new version of file1.bas. ! ! Adding /OUTPUT=file12_appended.bas would cause the procedure to only read ! file1.bas and file2.bas and create a file12_append.bas as the output file. ! ! Notes: ! 1. This TPU command procedure contains code to provide a mock-up ! version of the VAX Basic environment. ! That code is currented disabled by an EXIT command in the ! basic$$init procedure. ! If that line is commented out, the procedure will enter a loop reading ! in lines from SYS$INPUT. ! ! 2. In its current form, this procedure can be used to append BASIC ! programs together, along with sorting dealing with duplicate line ! numbers just as the VAX Basic interactive environment does or as ! the VAX Basic compiler did when file names were entered with ! "+"'s. ! ! The unsupported functions are listed at the top of the module, and ! will output a - not supported - message. An example of an ! unsupported function is LOAD. There is no way for TPU to handle ! loading in BASIC object modules. ! ! After those functions is the interface to the procedures which ! handle all the supported functions. ! ! The underlying support procedures follow. ! ! The following are "unspported" in the environment ! procedure basic$$not_supported (feature) message (""); message (fao(" -- BASIC$ENV Environment Feature !AS not supported.", feature)); endprocedure; procedure BASIC_run (arg) basic$$not_supported ("RUN"); return 1; endprocedure; ! ! Because the parser is "stupid" about matching ! names, comment out ambiguous runnh procedure ! !procedure BASIC_runnh (arg) !basic$$not_supported ("RUNNH"); !return 1; !endprocedure; procedure BASIC_scale (arg) basic$$not_supported ("SCALE"); return 1; endprocedure; procedure BASIC_set (arg) basic$$not_supported ("SET"); return 1; endprocedure; procedure BASIC_$ (arg) basic$$not_supported ("$"); return 1; endprocedure; procedure BASIC_assign (arg) basic$$not_supported ("ASSIGN"); return 1; endprocedure; procedure BASIC_compile (arg) ! ! This could work if there was some sub-process work added. ! It would be slow though! ! basic$$not_supported ("COMPILE"); return 1; endprocedure; procedure BASIC_continue (arg) basic$$not_supported ("CONTINUE"); return 1; endprocedure; procedure BASIC_edit (arg) basic$$not_supported ("EDIT"); return 1; endprocedure; procedure BASIC_help (arg) basic$$not_supported ("HELP"); return 1; endprocedure; procedure BASIC_identify (arg) basic$$not_supported ("IDENTIFY"); return 1; endprocedure; procedure BASIC_load (arg) basic$$not_supported ("LOAD"); return 1; endprocedure; procedure BASIC_lock (arg) basic$$not_supported ("LOCK"); return 1; endprocedure; procedure BASIC_unsave (arg) ! ! Delete a file from disk ! basic$$not_supported ("UNSAVE"); return 1; endprocedure; procedure BASIC_show (arg) basic$$not_supported ("SHOW"); return 1; endprocedure; procedure BASIC_rename (arg) basic$$not_supported ("RENAME"); return 1; endprocedure; procedure BASIC_resequence (arg) ! ! Resequence line numbers in current buffer. ! Appears to be easy, except for the cases where targets are given ! basic$$not_supported ("RESEQUENCE"); return 1; endprocedure; procedure BASIC_sequence (arg) ! ! Automaticly generate line numbers for input ! (in increments of 10, starting at 100) ! basic$$not_currently_supported ("SEQUENCE"); return 1; endprocedure; ! ! The following are "not currently supported". ! procedure basic$$not_currently_supported (feature) message (""); message (fao(" -- BASIC$ENV Environment Feature !AS not currently supported.", feature)); endprocedure; ! ! Interface to supported commands. ! procedure BASIC_append (arg) ! File to append, or null ! ! The "first" file is always the main buffer ! local file1; ! ! Was something passed or do we need to prompt? ! if (arg <> "") then file1 := arg; else file1 := basic$read_line ("Append file name--"); edit (file1, UPPER,TRIM_LEADING,TRIM_TRAILING); if file1 = "" then file1 := "NONAME.BAS" endif; endif; ! ! Call append. ! basic$$append_files (file1); return 1; endprocedure; procedure BASIC_delete (arg) ! ! Delete line numbers. Possible arguments are: ! DELETE 10 = Delete only line 10 ! DELETE 10, 20 = Delete lines 10 and 20 ! DELETE 10, 30-50 = Delete 10 and 30 through ! 50. local start_line, end_line, numbers_array, ! Numbers in the arg line_array, ! array containing line numbers counter; ! ! Do what VAX Basic does, and that is, if this routine is called, ! always warn the user about changes. ! basic$x_write_main_buffer := 1; ! ! Delete without any args is just a return. ! if arg = "" then return 1; endif; ! ! If the main buffer is empty, just return. ! Note that the flag is still being set so basic_exit will prompt ! (even though nothing is deleted!) ! if get_info (basic$x_main_buffer, "record_count") = 0 then return 1; endif; ! ! Can't do anything if the buffer does not have line ! numbers. ! position (beginning_of (basic$x_main_buffer)); if basic$$has_lines (basic$x_main_buffer) = 0 then message ("%BASIC$ENV-E-CMDNOTALL, command not allowed on programs without line numbers"); return 1; endif; ! ! ! Parse the buffer into the array indexed by the line numbers ! line_array := create_array (get_info (basic$x_main_buffer, "RECORD_COUNT")); basic$$parse_lines (basic$x_main_buffer, line_array); ! ! parse the arguments as line numbers and ! numbers_array := create_array (get_info (basic$x_main_buffer, "RECORD_COUNT")); ! ! Call routine to fill in the numbers array with the line numbers on the ! command line. ! if basic$$parse_line_list (arg, numbers_array) = 0 then ! No line numbers in arg. return 1; endif; counter := 1; loop start_line := numbers_array {counter}; end_line := numbers_array {counter + 1}; ! ! The array always has two entries, start and end, they can be equal ! counter := counter + 2; loop ! ! For each line in the range, set the array element to unspecified. ! line_array {start_line} := TPU$K_UNSPECIFIED; start_line := start_line + 1; exitif start_line > end_line; endloop; exitif get_info (numbers_array{counter}, "TYPE") = UNSPECIFIED; endloop; ! ! Now write that array into the scratch buffer ! erase (basic$x_scratch_buffer); position (beginning_of (basic$x_scratch_buffer)); ! counter := get_info (line_array, "first"); loop exitif counter = TPU$K_UNSPECIFIED; copy_text (line_array {counter}); counter := get_info (line_array, "NEXT"); endloop; ! ! Now that we have those ranges stored in the ! scratch buffer blow away the main buffer and copy ! the scratch buffer into it. ! erase (basic$x_main_buffer); position (basic$x_main_buffer); copy_text (basic$x_scratch_buffer); return 1; endprocedure; ! basic_delete procedure basic_exit ! exit (arg) ! usually nothing! ! ! Verify if any changes have been made they really want to ! exit. ! local saved_success; on_error [TPU$_CONTROLC]: set (SUCCESS, saved_success); message ("Operation aborted"); endon_error; saved_success := set (SUCCESS, OFF); if basic$x_write_main_buffer = 1 then ! ! If the buffer has not been written out, warn them ! that the next exit will loose there changes. ! don't warn them a second time unless they change ! the buffer again. ! message ("%BASIC$ENV-W-CHANGES, unsaved change has been made, CTRL/Z or EXIT to exit"); basic$x_write_main_buffer := 0; return 1; endif; exit; endprocedure; ! basic_exit procedure BASIC_list (arg) ! ! display the current buffer or range of lines to the screen, starting with ! file name and current time (up to hours/minutes). ! local the_time; the_time := substr (FAO ("!%D",0), 1, 17); message (FAO ("!AS !AS", FILE_PARSE (get_info (basic$x_main_buffer, "OUTPUT_FILE"),"","",NAME), the_time)); message (""); ! ! Now output the buffer or the lines requested. ! if arg <> "" then basic$$list_lines (arg); else message (basic$x_main_buffer); endif; return 1; endprocedure; ! ! This will always be called if the basic_list routine exists so ! comment it out for now. ! !procedure BASIC_listnh (arg) ! ! ! ! list current buffer to screen, no file name or time is output ! ! !message ("in listnh"); !return 1; !endprocedure; procedure BASIC_new (arg) ! ! Clears things out and takes param as file name. No attempt is made ! to verify that the file already exists. This is kind of associating the ! default buffer with a file name. ! ! There is no check made to see if current changes have been made. ! local file1, saved_success; on_error [otherwise]: abort; endon_error; if arg <> "" then file1 := arg; else message (""); file1 := basic$read_line ("New file name--"); edit (file1, UPPER,TRIM_LEADING,TRIM_TRAILING); if file1 = "" then file1 := "NONAME.BAS" endif; endif; saved_success := get_info (SYSTEM, "SUCCESS"); ! ! Add .bas if needed. ! file1 := file_parse (file1, ".BAS"); set (OUTPUT_FILE, basic$x_main_buffer, file1); ! ! Erase the main buffer ! erase (basic$x_main_buffer); return 1; endprocedure; ! basic NEW procedure BASIC_scratch (arg) ! ! Clear memory, resets everything as if we just entered. ! erase (basic$x_main_buffer); set (OUTPUT_FILE, basic$x_main_buffer, "NONAME.BAS"); basic$x_write_main_buffer := 0; return 1; endprocedure; ! End of basic_scratch procedure BASIC_old (arg) ! ! Read in an existing file, error if the file does not exist, output error ! local file1,saved_success,search_result; on_error [otherwise]: SET (SUCCESS, saved_success); abort; endon_error; if arg <> "" then file1 := arg; else message (""); file1 := basic$read_line ("Old file name--"); edit (file1, UPPER,TRIM_LEADING,TRIM_TRAILING); if file1 = "" then file1 := "NONAME.BAS" endif; endif; saved_success := get_info (SYSTEM, "SUCCESS"); ! ! Add .bas if needed. ! file1 := file_parse (file1, ".BAS"); ! ! Try to find the file, first clear the file_search ! search_result := file_search (""); search_result := file_search (file1); if (search_result = "") then ! ! Didn't find the file. ! basic$$nosuch_file (file1); return 1; endif; set (OUTPUT_FILE, basic$x_main_buffer, search_result); ! ! Read the file into the main buffer. ! erase (basic$x_main_buffer); position (basic$x_main_buffer); set (SUCCESS, OFF); read_file (search_result); SET (SUCCESS, saved_success); ! ! Sort the buffer. ! basic$$sort_lines (basic$x_main_buffer); return 1; endprocedure; ! basic_old procedure BASIC_replace (arg) ! ! Write buffer out, using defaults from the buffer. ! if arg <> "" then message ("%BASIC$ENV-E-NOFILEALL, a file specification is not allowed with the REPLACE command"); else write_file (basic$x_main_buffer); endif; return 1; endprocedure; procedure BASIC_save (arg) ! ! Write buffer out to file. - takes optional param (file-name) ! local file1; if arg = "" then write_file (basic$x_main_buffer); else file1 := file_parse (arg, ".BAS"); ! ! The buffer name does not get updated ! when the SAVE command is used. ! write_file (basic$x_main_buffer, file1); endif; ! ! If SAVE is done, we no longer need to check on exit ! if the buffer should written. ! basic$x_write_main_buffer := 0; return 1; endprocedure; ! basic_save procedure BASIC$$append_files (file_to_append) ! file to append ! ! Append the file passed in to the buffer passed in. ! local saved_success, tmp_buffer, ! buffer to use to read in this file. line_array_1, line_array_2, search_result, out_buffer_filename, default_parse_string, array_index, the_line_range, file1; on_error [TPU$_CONTROLC]: set (SUCCESS, saved_success); abort; [OTHERWISE]: set (SUCCESS, saved_success); endon_error; saved_success := get_info (SYSTEM, "success"); ! for error handler ! ! Create a default string for file-parse using the ! output file from the buffer passed in. ! out_buffer_filename := get_info (basic$x_main_buffer, "OUTPUT_FILE"); default_parse_string := file_parse (out_buffer_filename, "", "", HEAD, TYPE); file1 := file_parse (file_to_append, "", default_parse_string); search_result := file_search (""); ! ! make sure the file exits ! search_result := file_search (file1); if (search_result = "") then basic$$nosuch_file (file1); return 1; endif; ! ! Read in the file, setting the buffer to nowrite ! set (SUCCESS, OFF); tmp_buffer := create_buffer ("appending buffer", search_result); set (NO_WRITE, tmp_buffer); set (SUCCESS, saved_success); if basic$$has_lines (tmp_buffer) = 0 then message ("%BASIC$ENV-E-APPNOTALL, append not allowed on programs without line numbers"); message (FAO ("File: !AS", search_result)); delete (tmp_buffer); return 1; endif; ! ! If the user wants info about what is being appended ! this line will display what file is being appended to ! the screen ! !message (FAO ("-- appending file !AS", search_result)); ! ! Call procedure to split up the main buffer and put the ! results into the local array. ! line_array_1 := create_array (get_info (basic$x_main_buffer, "record_count")); basic$$parse_lines (basic$x_main_buffer, line_array_1); ! ! Call routine again, this time to parse the file to append. ! line_array_2 := create_array (get_info(tmp_buffer, "record_count")); basic$$parse_lines (tmp_buffer, line_array_2); ! ! Call routine to merge the two arrays. ! basic$$merge_lines (line_array_1, line_array_2); ! ! Output each element of the array into the scratch buffer. erase (basic$x_scratch_buffer); position (beginning_of (basic$x_scratch_buffer)); ! array_index := get_info (line_array_1, "FIRST"); loop exitif array_index = TPU$K_UNSPECIFIED; copy_text (line_array_1 {array_index}); array_index := get_info (line_array_1, "NEXT"); endloop; ! ! Now that we have those ranges stored in the scratch buffer blow away ! the input buffer and copy the scratch buffer into it. ! erase (basic$x_main_buffer); position (basic$x_main_buffer); copy_text (basic$x_scratch_buffer); delete (tmp_buffer); endprocedure; ! basic$$append_files procedure basic$$merge_lines (array1, ! "master" lines array2) ! Lines to merge in into ! array_one local array1_index, array2_index; ! array2_index := get_info (array2, "FIRST"); loop exitif array2_index = TPU$K_UNSPECIFIED; ! ! Does array1 have a similar index? ! if get_info (array1 {array2_index}, "TYPE") <> UNSPECIFIED then ! ! Output a message ! message (FAO ("%BASIC$ENV-I-DUPLNFND, duplicate line number !SL found", array2_index)); endif; array1 {array2_index} := array2 {array2_index}; array2_index := get_info (array2, "NEXT"); endloop; endprocedure; procedure basic$$list_lines (the_lines_to_list) ! ! List the lines specified in the string passed in ! local line_array, numbers_array, start_line, end_line, counter; ! ! Don't bother doing anything if there is nothing in the main buffer. ! if get_info (basic$x_main_buffer, "record_count") = 0 then return 1; endif; ! ! Parse the buffer into the array indexed by the line numbers ! line_array := create_array (get_info (basic$x_main_buffer, "RECORD_COUNT")); basic$$parse_lines (basic$x_main_buffer, line_array); ! ! Create array to hold line numbers. ! numbers_array := create_array (get_info (basic$x_main_buffer, "RECORD_COUNT")); ! ! Call routine to fill in the numbers array with the line numbers on the ! command line. ! if basic$$parse_line_list (the_lines_to_list, numbers_array) = 0 then ! No line numbers in arg. return; endif; counter := 1; loop start_line := numbers_array {counter}; end_line := numbers_array {counter + 1}; ! ! The array always has two entries, start and end, they can be equal ! counter := counter + 2; loop ! ! Output each line in the range (if the line exists) ! if get_info (line_array {start_line}, "type") <> UNSPECIFIED then message (line_array {start_line}); endif; start_line := start_line + 1; exitif start_line > end_line; endloop; exitif get_info (numbers_array{counter}, "TYPE") = UNSPECIFIED; endloop; endprocedure; ! basic$$list_lines procedure basic$$add_line (new_line) ! ! A a new line to the main buffer, but if that line ! already exists, replace it with the new one. ! ! If this is to work correctly, the current buffer would have to ! be sorted, then this line would have to be parsed to find the line ! number, and then added to the array (checking for duplicates) and then ! the array would be written back into the buffer. ! In other words, it would be slow, but it could be made to work. ! message (" ** basic$$add_line called with " + new_line); endprocedure; procedure basic$$line_starts_with_digits (the_command) ! string to check to see if it starts ! with digits (ie a valid line number ! ! Return 0 = command does not start with a digit ! return 1 = contains a digit starting at first char ! case substr (EDIT (the_command, TRIM_LEADING), 1, 1) ["0","1","2","3","4","5","6","7","8","9"] : return 1; [otherwise] : return 0; endcase; endprocedure; procedure basic$$sort_lines (buffer_to_sort) ! ! Sort the buffer by line number. ! ! Assumes that the buffer has been checked to see if it contains ! line numbers. ! local cur_mark,line_array,array_index; cur_mark := mark (NONE); line_array := create_array (get_info (buffer_to_sort, "record_count")); basic$$parse_lines (buffer_to_sort, line_array); ! ! Output each element of the array into ! the scratch buffer. ! erase (basic$x_scratch_buffer); position (beginning_of (basic$x_scratch_buffer)); ! array_index := get_info (line_array, "FIRST"); loop exitif array_index = TPU$K_UNSPECIFIED; copy_text (line_array {array_index}); array_index := get_info (line_array, "NEXT"); endloop; ! ! Now that we have those ranges stored in the ! scratch buffer blow away the input buffer and copy ! the scratch buffer into it. ! erase (buffer_to_sort); position (buffer_to_sort); copy_text (basic$x_scratch_buffer); ! ! Position back to where we were when we started. ! position (cur_mark); endprocedure; procedure basic$$parse_line_list (str_to_parse, ! Input/output string numbers_array) ! Array to put numbers into. ! ! Parse the string, looking for a single line number or a range. The ! numbers are put into the numbers_array - two for each line or range in the ! str_to_parse. ! ! for example, if the line contained 10, 30-50 the array would contain entries ! 10, 10, 30, 50. ! ! Returns 0 - No line number found. ! # of line numbers ! local seperator_range, local_str, seperator, prev_seperator, cur_pos, array_index, tmp_range, line_number_pattern, number_range; local_str := edit (str_to_parse, COLLAPSE, OFF); if local_str = "" then return 0; endif; cur_pos := mark (none); position (basic$x_scratch_buffer); erase (current_buffer); copy_text (local_str); position (beginning_of (basic$x_scratch_buffer)); if basic$$line_starts_with_digits (current_line) = 0 then message ("%BASIC$ENV-E-LINNUMERR, illegal line number"); return 0; endif; line_number_pattern := ( (SPAN (basic$k_digits) @ number_range) + (("," | "-" | "") @ seperator_range)); array_index := 1; prev_seperator := ""; seperator := ""; tmp_range := search_quietly (line_number_pattern, FORWARD, NO_EXACT); loop if tmp_range = 0 then ! ! Did not find a number, see if we ! should report "illegal number" ! if prev_seperator = "-" then ! ! Processing a range, ignore the ! last number. ! numbers_array {array_index} := TPU$K_UNSPECIFIED; array_index := array_index - 1; endif; exitif 1; endif; ! ! Put the number in the array. ! numbers_array {array_index} := int (str (number_range)); ! ! What did we end with? ! seperator := substr ( str (seperator_range), 1, 1); case seperator [",", ""] : ! ! A comma or the end of the string ! if prev_seperator <> "-" then ! ! We are not dealing with a range, duplicate ! the prevous array index and bump the index. ! numbers_array {array_index + 1} := numbers_array {array_index}; array_index := array_index + 2; else ! ! We were dealing with a range, we've already ! put the number in the array, just increment ! the array index. ! array_index := array_index + 1; endif; ! ! Erase the range. ! erase (tmp_range); ["-"] : ! ! A "range", move beyond it and let the next time through the ! loop set the index. ! array_index := array_index + 1; ! ! Erase the range ! erase (tmp_range); [OTHERWISE] : ! ! End, lets hope everthing is OK :-) ! erase (tmp_range); endcase; ! ! Search for the next number. ! prev_seperator := seperator; ! ! prev range has been erased, this better be a number ! next or output an "illegal line number" message ! if (seperator <> "") AND (seperator <> "-") then if basic$$line_starts_with_digits (current_line) = 0 then message ("%BASIC$ENV-E-LINNUMERR, illegal line number"); numbers_array {array_index} := TPU$K_UNSPECIFIED; array_index := array_index - 1; exitif 1; endif; endif; tmp_range := search_quietly (line_number_pattern, FORWARD, NO_EXACT); endloop; ! ! Go back to where we were and return # array elements ! position (cur_pos); return array_index - 1; endprocedure; procedure BASIC$proc_to_cmd_name ! Convert cmd procedure name to cmd name (arg) ! command procedure name ! Convert "BASIC_CLEAR" to "CLEAR" local temp; temp := substr (arg, length ("BASIC_")); translate (temp, " ", "_"); edit (temp, TRIM); return (temp); endprocedure; ! basic$proc_to_cmd_name procedure basic$$add_args_to_cmd ! Add args to command as quoted string (the_command, ! parsed command, e.g, BASIC_TYPE - input args) ! rest of command line - input ! Procedure to add all arguments to the parsed command. Since the parser ! passes all args to the command procedures between double quotes, double ! up on each double-quote character found in the args. This is because ! TPU requires you to type the quote character twice if you use the same char ! as the delimiter. For example, '''' = '; 'abc''def' = abc'def; and so on. ! To test, execute the following command and reply to the prompt with: ! "f'o" thru 'b"r'. The resulting message should be: ! ""f'o"" thru 'b""r' local ix, c, len, result, rest; on_error [OTHERWISE]: endon_error; ! If no double-quote characters in arguments, just return the command + args if (index (args, '"') = 0) then return (the_command + '("' + args + '")'); endif; result := the_command + '("'; rest := args; len := length (args); ix := 1; loop exitif ix > len; c := substr (rest, ix, 1); result := result + c; if c = '"' then result := result + '"'; endif; ix := ix + 1; endloop; return (result + '")'); endprocedure; ! basic$$add_args_to_cmd procedure basic$display_ambiguous ! Show all ambiguous commands (arg) ! Convert list of ambiguous commands, e.g., "BASIC_BUFF BASIC_BUFFER" to ! "BUFF BUFFER", and display it. Like EVE's choices buffer display local local_arg, result, ix, spc_ix, rest, saved_mark, max, what_column, total_width, how_many_columns, how_many_items, leftover, which_column, string_position, which_item, spaces, this_position; on_error [TPU$_CONTROLC]: position (saved_mark); abort; endon_error; saved_mark := mark (NONE); erase (basic$x_scratch_buffer); position (basic$x_scratch_buffer); local_arg := arg; copy_text (local_arg); ! put 1 command per line, and get rid OF "BASIC_" and "_"s set (RIGHT_MARGIN, basic$x_scratch_buffer, 5); fill (basic$x_scratch_buffer); set (RIGHT_MARGIN, basic$x_scratch_buffer, 79); position (buffer_begin); loop exitif mark (NONE) = end_of (basic$x_scratch_buffer); erase_character (length ("BASIC_")); move_vertical (1); endloop; translate (basic$x_scratch_buffer, " ", "_"); how_many_items := get_info (basic$x_scratch_buffer, "record_count"); ! get the length of the longest line in the buffer position (buffer_begin); max := 0; loop exitif mark (NONE) = end_of (basic$x_scratch_buffer); if max < length (current_line) then max := length (current_line); endif; move_vertical (1); endloop; total_width := get_info (SCREEN, "width"); ! determine the number of columns (items) that can be on a line max := max + 2; how_many_columns := (total_width - 1) / max; if (how_many_columns * max) > total_width then ! rounded up how_many_columns := how_many_columns - 1; endif; if how_many_columns = 0 then how_many_columns := 1; else if how_many_items < how_many_columns then ! adjust for number of items < number that would fit on a line how_many_columns := how_many_items; max := (total_width - 1) / how_many_items; if (how_many_columns * max) > total_width then ! rounded up max := max - 1; endif; else ! adjust for number of items > number that would fit on a line loop leftover := (total_width - 1) - (how_many_columns * max); exitif leftover < how_many_columns; max := max + 1; endloop; endif; endif; which_column := 1; string_position := 1; position (beginning_of (basic$x_scratch_buffer)); split_line; spaces := fao ("!80* "); loop exitif mark (NONE) = end_of (basic$x_scratch_buffer); which_item := erase_line; move_horizontal (-1); if (which_column = 1) and (max <= total_width) then copy_text (" "); endif; copy_text (which_item); if which_column = how_many_columns then if how_many_columns = 1 then ! letter wrap this_position := mark (NONE); loop position (LINE_END); what_column := get_info (basic$x_scratch_buffer, "offset_column"); exitif what_column <= total_width; move_horizontal (total_width - what_column); split_line; endloop; position (this_position); endif; split_line; which_column := 1; else copy_text (substr (spaces, 1, max - length (which_item))); which_column := which_column + 1; endif; move_horizontal (1); endloop; append_line; ! show ambiguous commands message (basic$x_scratch_buffer); position (saved_mark); return 1; ! endprocedure; ! tle$display_ambiguous procedure basic$parse_command ! Parse a command (the_command) ! command to parse ! Command parser. ! Rejects unknown commands. Returns "" if nothing parsed. ! Displays list of matching commands if an ambiguous command. local amb_parse, ix, c, cmd, parse_result, local_cmd, token, saved_parse_result, saved_local_cmd, new_cmd, doit, first_pass, lookahead, built_pattern; on_error [TPU$_CONTROLC]: message ("Operation aborted"); learn_abort; [TPU$_NONAMES]: [TPU$_MULTIPLENAMES]: amb_parse := 1; endon_error; local_cmd := the_command; edit (local_cmd, TRIM); if local_cmd = "" then ! Blank line return (""); endif; first_pass := 1; ! Loop doing expand_name on string built from each additional token ! in the command line. If ambiguous, display the choices. If we get ! a match, keep adding tokens until we don't get a match - then back ! off the last token because it was possibly an argument for the command. loop exitif local_cmd = ""; amb_parse := 0; ! Get next token by looking for first white space after it. ix := 1; loop exitif index (basic$k_whitespace, substr (local_cmd, ix, 1)) <> 0; ix := ix + 1; exitif ix > length (local_cmd); endloop; token := substr (local_cmd, 1, ix - 1); local_cmd := substr (local_cmd, ix); edit (local_cmd, TRIM_LEADING); if first_pass then new_cmd := "BASIC_" + token + "*"; built_pattern := "BASIC_" + token; else new_cmd := new_cmd + "*_" + token + "*"; built_pattern := built_pattern + (span (basic$k_alphamerics) | "") + ('_' + token); endif; basic$x_parse_pattern := built_pattern + (span (basic$k_alphamerics) | ""); parse_result := expand_name (new_cmd, PROCEDURES); ! Handle 1st token here if nothing matched it. if (not amb_parse) and (parse_result = "") and first_pass then if basic$$line_starts_with_digits (the_command) then basic$$add_line (the_command); else message ("%BASIC$ENV-E-UNKNOWN, Unrecognized command: !AS", 0, the_command); endif; return (""); endif; first_pass := 0; if (not amb_parse) and (parse_result = "") then ! No match if not lookahead then !????? can this return "Unrecognized cmd"???? ! Adding this token did not help resolve ambiguity. message ("Ambiguous command: !AS", 0, the_command); ! tle$display_ambiguous (saved_parse_result); return (""); else ! Adding this token must have eaten an arg, back it out and ! return the command with this token as an arg. parse_result := saved_parse_result; local_cmd := saved_local_cmd; doit := 1; endif; endif; if (not amb_parse) and (parse_result <> "") then ! Got a match if local_cmd = "" then ! No more on cmd line, return it. doit := 1; else ! Insure we get all cmd tokens and stop when/if we hit an arg. lookahead := 1; endif; endif; ! See if we found something if doit then ! Return the command that matched. if get_info (PROCEDURES, "maximum_parameters", parse_result) = 0 then if local_cmd <> "" then message ("!AS does not take any arguments.", 0, basic$proc_to_cmd_name (parse_result)); return (""); else return (parse_result); endif; else if local_cmd = "" then return (parse_result + '("")'); else return (basic$$add_args_to_cmd (parse_result, local_cmd)); endif; endif; endif; saved_parse_result := parse_result; saved_local_cmd := local_cmd; endloop; if amb_parse then message ("Ambiguous command: !AS", 0, the_command); basic$display_ambiguous (saved_parse_result); else message ("%BASIC$ENV-E-UNKNOWN, Unrecognized command: !AS", 0, the_command); endif; return (""); endprocedure; ! basic$parse_command procedure basic$$nosuch_file (missing_file) ! ! Signal a file not found message ! message (FAO ("%BASIC$ENV-F-OPENIN, error opening !AS as input", missing_file)); ! This is rms$_fnf message (98962); endprocedure; procedure basic$$parse_lines (the_buffer, ! Buffer to parse the_array) ! Array to put results local line_number_pattern, line_numb, number_range, start_mark, tmp_line, search_range, tmp_range; ! ! A line number can either start at the beginning of a line, or ! have spaces then a line. ! line_number_pattern := LINE_BEGIN + (SPAN (basic$k_whitespace) | "") + (SPAN (basic$k_digits) @ number_range) + (basic$k_whitespace | ""); position (beginning_of (the_buffer)); start_mark := mark (NONE); ! ! Skip all blank and null lines. ! basic$$skip_blank_lines (the_buffer); ! ! do the first search outside to make loop processing ! easier ! search_range := search_quietly (line_number_pattern, FORWARD, NO_EXACT); if search_range = 0 then ! ! Line number not found, return right away. ! return; else ! ! Position to the end of the range that was found. ! position (end_of (search_range)); ! End of first line # if mark (NONE) <> end_of (current_buffer) then ! ! Move beyond number by one char (as long as we are not sitting ! at the end of the buffer. ! move_horizontal (1); endif; endif; line_numb := int (EDIT (str (number_range), COLLAPSE)); loop ! ! Search ahead for another line number ! search_range := search_quietly (line_number_pattern, FORWARD, NO_EXACT); if search_range = 0 then ! ! did not find a next line number, put the range ! in the array from the last start mark to the end of the ! buffer ! if get_info (the_array {line_numb}, "TYPE") <> UNSPECIFIED then message (FAO ("%BASIC$ENV-I-DUPLNFND, duplicate line number !SL found", line_numb)); endif; the_array {line_numb} := create_range ( start_mark, end_of (the_buffer), NONE); exitif 1; endif; ! ! Found another line number, position to the beginning of it, ! move back one line ! ! For example: ! 10 print "hi" ! 20 print "bye" ! ! At this point, we would position to "20", then to "10", then to the ! end of "hi". ! position (beginning_of (search_range)); ! At the start of the number move_vertical (-1); ! Back one line position (line_end); ! End of that line ! ! The range we create is from the start of the previous line number ! to the end of the line directly above where this new line number ! was found. ! tmp_range := create_range (start_mark, MARK (NONE), NONE); ! ! Check for the previous line ending with an & which means ! that someone has continued a statement onto the next line ! and it should be considered part of the current line. ! if length (tmp_range) < 65535 then ! The range will fit into a line. tmp_line := edit (STR (tmp_range), TRIM_TRAILING, OFF); else ! ! The range won't fit into a line, assume that no & is sitting ! at the end of the line that has over 65K characters in it. ! tmp_line := "" endif; if substr (tmp_line, length (tmp_line), 1) <> "&" then if get_info (the_array {line_numb}, "TYPE") <> UNSPECIFIED then message (FAO ("%BASIC$ENV-I-DUPLNFND, duplicate line number !SL found", line_numb)); endif; the_array {line_numb} := tmp_range; ! ! Reset the line number ! line_numb := int (EDIT (str (number_range), COLLAPSE)); ! ! Reset start mark by moving back down one line ! then to the beginning of the line. ! move_vertical (1); ! Back position (line_begin); start_mark := MARK (none); endif; ! ! Now go to the end of the range so we don't find that ! number again. ! position (end_of (search_range)); ! ! Move one position beyond the end of the search range. This will ! make sure that if we have a single digit, we skip over the entire range. move_horizontal (1); endloop; endprocedure; ! End of $$parse_lines procedure basic$$has_lines (the_buffer) ! Buffer to validate ! ! Validate that the buffer passed a "valid line" ! program (first line has numbers) ! local saved_mark; saved_mark := mark (NONE); position (beginning_of (the_buffer)); basic$$skip_blank_lines (the_buffer); ! ! Make sure the first line has only digits ! if (search_quietly ( ANCHOR + (SPAN (basic$k_whitespace) | "") ! skip tab/space or "" + SPAN (basic$k_digits) ! Any digit will do + (basic$k_whitespace | ""), FORWARD, NO_EXACT) = 0) then position (saved_mark); return 0; endif; position (saved_mark); return 1; endprocedure; procedure basic$$skip_blank_lines (the_buffer) ! Skip any null and blank lines ! ! ! if mark (NONE) = end_of (current_buffer) then ! ! If the buffer is empty, get out ! return; endif; ! ! Loop skiping blank lines. ! loop exitif EDIT (current_line, COMPRESS, OFF) <> ""; move_vertical (1); exitif mark (NONE) = end_of (current_buffer); endloop; endprocedure; procedure basic$append_and_sort; ! ! Command line had at least one file on it, lets read in that ! file, then call routine to append next file to it ! Handle all files on the command line. ! ! If the /output is specified, create that file, otherwise ! write the file out to the first filename. ! local file1, first_time, search_result, saved_success, input_file, parse_name; message (""); message (" - BASIC$ENV - Append and Sort Procedure"); message (""); ! ! Loop through the files on the command line, using ! the first as the output file and ! input_file := get_info (command_line, "first_file_name"); first_time := 1; ! ! Reset file_search ! file1 := file_search (""); loop if first_time = 1 then ! ! first time in, setup the output buffer and make ! sure the file is around. ! ! Parse the input file, adding .BAS if needed. ! file1 := file_parse (input_file, ".BAS"); search_result := file_search (file1); if (search_result = "") then ! ! We die if the input files are found ! basic$$nosuch_file (file1); exit; endif; ! ! Default the main buffer's output file to ! be the search result of the first file. ! set (OUTPUT_FILE, basic$x_main_buffer, search_result); ! ! Clear the main buffer (just in case) ! erase (current_buffer); ! position (basic$x_main_buffer); saved_success := get_info (SYSTEM, "SUCCESS"); set (SUCCESS, OFF); read_file (search_result); SET (SUCCESS, saved_success); ! ! If the program does not start with ! line numbers, stop here! ! if basic$$has_lines (basic$x_main_buffer) = 0 then message ("%BASIC$ENV-E-APPNOTALL, append not allowed on programs without line numbers"); message (FAO ("File: !AS", search_result)); exit; endif; ! ! Sort the lines. ! basic$$sort_lines (basic$x_main_buffer); ! ! For debugging, Let user know what we are appending to. ! ! message (FAO ("Appending to file !AS", search_result)); first_time := 0; else ! ! We need to get each file on the command line ! input_file := get_info (command_line, "next_file_name"); exitif input_file = 0; basic$$append_files (input_file); endif; endloop; ! ! If there was a filename used for /output, ! use that filename to output the buffer. ! if get_info (command_line, "OUTPUT_FILE") <> "" then set (OUTPUT_FILE, basic$x_main_buffer, file_parse (get_info(command_line, "OUTPUT_FILE"), ".BAS")); endif; ! ! make sure the user wanted the output file. ! if (get_info (command_line, "OUTPUT") = 1) then write_file (basic$x_main_buffer); endif; ! ! We are done. ! exit; endprocedure; procedure basic$read_line (prompt) on_error [TPU$_CONTROLC]: return (read_line (prompt)); endon_error; return (read_line (prompt)); endprocedure; ! basic$read_line procedure tpu$init_procedure ! Do module_init ! ! Called before /command is executed so if this is in a section file ! this gets exectuted first... ! basic$$init; ! Set up everything endprocedure; ! tpu$init_procedure procedure tpu$local_init endprocedure; procedure basic$$init ! Create the system buffers. basic$x_scratch_buffer := create_buffer ("SCRATCH"); set (NO_WRITE, basic$x_scratch_buffer); set (SYSTEM, basic$x_scratch_buffer); ! ! Always need a main buffer, set it to no_write and ! control the writting of it in the exit routine. ! basic$x_main_buffer := create_buffer ("MAIN"); set (NO_WRITE, basic$x_main_buffer); set (OUTPUT_FILE, basic$x_main_buffer, "NONAME.BAS"); position (basic$x_main_buffer); ! Global variable setup basic$x_user_command := ""; basic$x_write_main_buffer := 0; basic$k_whitespace := " "; ! space + tab basic$k_digits := "1234567890"; basic$k_lowercase := "abcdefghijklmnopqrstuvwxyz"; basic$k_uppercase:= "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; basic$k_alphamerics := basic$k_lowercase + basic$k_uppercase; basic$x_parse_pattern := ""; ! Global settings !set (MESSAGE_FLAGS, 1); ! ! Used when EXECUTE is called. ! basic$x_error_handler := "on_error [TPU$_CONTROLC]: learn_abort;" + "[OTHERWISE]:endon_error; return "; ! ! If there is an input file, we go directly into "append and resequence" mode ! if get_info (COMMAND_LINE, "file_name") <> "" then ! basic$append_and_sort; exit; endif; ! ! No file name on the command line ! define_key ("basic_exit ('')", ctrl_z_key, "exit"); ! ! Disable entering "interactive" mode. If customers wish to, the following ! two lines can be commented out which will cause the tpu$init_postprocedure ! to enter main loop ! ! message ("%BASIC$ENV-I-NOFILE, Must enter file name for Append and sort to function"); exit; !SET(TRACEBACK,ON);!********** FOR DEBUG ********* endprocedure; ! End of bas$$init procedure tpu$init_postprocedure ! The main loop ! ! Called after /command is processed. ! ! This is the main loop. It loops here reading ! commands from the user, and never enters TPU's main key-reading loop. local parse_result; on_error [TPU$_CONTROLC]: return (basic$read_line ("")); endon_error; if (get_info (basic$x_main_buffer, "TYPE") = UNSPECIFIED) then basic$$init; endif; position (basic$x_main_buffer); basic$x_last_buffer := current_buffer; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! M A I N L O O P ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! message ("-- BASIC$ENV Environment From TPU"); message ("-- Copyright 1994 Compaq Computer Corporation"); message (""); message ("-- Limited BASIC Enviornment Functions available --"); message (""); message ("BASIC$ENV Ready"); message (""); loop basic$x_user_command := basic$read_line (""); if last_key = CTRL_Z_KEY then basic_exit (""); else parse_result := basic$parse_command (basic$x_user_command); if parse_result <> "" then ! ! Try to execute it, putting the error handler in line ! also ! if execute (basic$x_error_handler + parse_result) = 0 then ! For debugging ! message ("Execution failed for command: !AS", 0, parse_result); endif; ! ! If user wants to be informed that the command was not known more ! than the parse_command does, uncomment this else statement. ! else ! message (""); ! unrecognized command endif; endif; message ("BASIC$ENV Ready"); message (""); endloop; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! E N D O F M A I N L O O P ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! endprocedure; ! tpu$init_postprocedure ! ! Module init code - Code in the module that is executed as "unbound" code ! basic$$init; endmodule;