get_seg_ptr_.pl1 11/05/86 1509.8r w 11/04/86 1042.7 85095 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* This procedure was initially coded by Richard H. Gumpertz on 1/7/71 Procedure last modified: 04/10/71 at 1536 by RHG to rename get_seg_ptr_$** to get_seg_ptr_** to use the already installed copy of stack_frame.incl.pl1 03/31/71 at 1428 by RHG to add entry point get_seg_ptr_arg_ 03/24/71 at 1758 by RHG to clear return_code in $search 03/24/71 at 1714 by RHG to make things a bit neater 03/22/71 at 0357 by RHG to rename open_seg_ to get_seg_ptr_ to combine get_seg_ptr_ and release_seg_ptr_ to add the entry point $search to change wanted_access from fixed bin(5) to bit(6) aligned 01/20/71 at 1820 by RHG to supress hcs_$initiate_count errors such as "segknown" 01/18/71 at 1104 by RHG to reformat the source 01/17/71 at 1951 by RHG to speed up open_seg_$path 01/17/71 at 1251 by RHG for initial implementation 11/14/73 by Kobziar to not check append access 11/30/77 by David Levin to zero unused part of last word. */ /* This procedure opens a segment for reading or writing, returning a pointer and a bit_count. If the segment does not exist and "create" access was specified in the call then an attempt is made to create the segment. A non-null pointer is returned if the segment is initiated. An error code will be returned in return_code if the access to the segment is not at least that specified in wanted_access. Otherwise any error return will have the return_ptr null. The entry point get_seg_ptr_arg_ is identical to the main entry except that the pathname is fetched out of the caller's argument list. The entry point get_seg_ptr_full_path_ is identical to the main entry except that a directory name and an entry name are taken rather than a relative path name. The entry point get_seg_ptr_search_ initiates the segment via search rules but initiates the segment with a null reference name. If it creates a segment it creates it in the process directory. The entry point release_seg_ptr_ terminates a segment. It also truncates the segment and sets its bit count if a nonnegative bit count is given. */ /* */ get_seg_ptr_: procedure (path_name, wanted_access, bit_count, return_ptr, return_code); call expand_pathname_ (path_name, directory_name, entry_name, error_code); if error_code ^= 0 then goto error_return; goto common; get_seg_ptr_arg_: entry (arg_number, wanted_access, bit_count, return_ptr, return_code); call cu_$arg_ptr_rel (arg_number, temp_ptr, len, error_code, cu_$stack_frame_ptr () -> prev_sp -> arg_ptr); if error_code ^= 0 then goto error_return; call expand_pathname_ (path_name_arg, directory_name, entry_name, error_code); if error_code ^= 0 then goto error_return; goto common; get_seg_ptr_full_path_: entry (d_name, e_name, wanted_access, bit_count, return_ptr, return_code); directory_name = d_name; entry_name = e_name; goto common; get_seg_ptr_search_: entry (ref_name, wanted_access, bit_count, return_ptr, return_code); call hcs_$fs_get_seg_ptr (ref_name, temp_ptr, error_code); if temp_ptr ^= null then /* temp_ptr = null if seg not known */ do; call hcs_$fs_get_path_name (temp_ptr, directory_name, len, entry_name, error_code); /* get the path name of the segment */ if error_code ^= 0 then goto error_return; goto common; end; call hcs_$make_ptr (null_string, ref_name, null_string, temp_ptr, error_code); /* search for the segment */ if temp_ptr = null then /* temp_ptr = null if seg doesn't exist */ do; if substr (wanted_access, 6, 1) = "0"b then goto error_return; /* return if "create" bit not on */ directory_name = get_pdir_ (); /* else create the segment in the process dir */ entry_name = ref_name; return_code = 0; goto create; end; call hcs_$fs_get_path_name (temp_ptr, directory_name, len, entry_name, error_code); /* get the path name of the seg */ if error_code ^= 0 then goto error_return; call hcs_$terminate_name (ref_name, error_code); /* terminate the name we just made known */ if error_code ^= 0 then goto error_return; goto common; release_seg_ptr_: entry (seg_ptr, bit_count, return_code); return_code = 0; goto release; /* */ dcl path_name char (*), path_name_arg char (len) based (temp_ptr), arg_number fixed bin, ref_name char (*), d_name char (*), e_name char (*), seg_ptr ptr, wanted_access bit (6) aligned, bit_count fixed bin (24), word_count fixed bin (24), word_mask (0:3) bit (36) aligned int static options (constant) init ("777777777777"b3, "777000000000"b3, "777777000000"b3, "777777777000"b3), segment (262144) bit (36) aligned based, return_ptr ptr, return_code fixed bin (35); dcl (addr, divide, fixed, length, mod, null, substr) builtin; dcl (error_table_$moderr, error_table_$noentry) fixed bin (35) external; dcl expand_pathname_ external entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)), cu_$stack_frame_ptr external entry () returns (ptr), cu_$arg_ptr_rel external entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr), get_pdir_ external entry () returns (char (168) aligned), hcs_$status_ external entry (char (*) aligned, char (*) aligned, fixed bin, ptr, ptr, fixed bin (35)), hcs_$initiate_count external entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin, ptr, fixed bin (35)), hcs_$append_branch external entry (char (*) aligned, char (*) aligned, fixed bin (5), fixed bin (35)), hcs_$fs_get_path_name external entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin (35)), hcs_$fs_get_seg_ptr external entry (char (*), ptr, fixed bin (35)), hcs_$make_ptr external entry (char (*) aligned, char (*), char (*) aligned, ptr, fixed bin (35)), hcs_$terminate_name external entry (char (*), fixed bin (35)), hcs_$set_bc external entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (35)), hcs_$truncate_seg external entry (ptr, fixed bin (24), fixed bin (35)), hcs_$terminate_noname external entry (ptr, fixed bin (35)); %include status_info_branch; %include stack_frame; dcl error_code fixed bin (35), directory_name char (168) aligned, entry_name char (32) aligned, temp_ptr ptr, len fixed bin; dcl null_string char (0) aligned internal static initial (""); /* */ common: return_code = 0; /* initialize */ call hcs_$status_ (directory_name, entry_name, 1, addr (status_info_branch), null, error_code); /* find out if the seg exists and the access we have to it */ if error_code ^= 0 then goto create_seg; /* if error, seg probably didn't exist */ if substr (wanted_access, 1, 4) & ^mode then return_code = error_table_$moderr; /* make sure he has at least the access requested */ initiate_seg: call hcs_$initiate_count (directory_name, entry_name, null_string, bit_count, 1, return_ptr, error_code); /* initiate the segment with null reference name */ if return_ptr = null then goto error_return; /* check return_ptr not error_code to avoid "segknown" etc. */ return; create_seg: if error_code ^= error_table_$noentry then goto error_return; /* make sure the problem really was that seg didn't exist */ if substr (wanted_access, 6, 1) = "0"b then goto error_return; /* don't create the seg unless "create" access specified */ create: call hcs_$append_branch (directory_name, entry_name, fixed (substr (wanted_access, 1, 5), 5, 0), error_code); /* create the segment */ if error_code = 0 then goto initiate_seg; /* if OK then go initiate the segment */ /* else we have an error */ error_return: /* we get here if we have an error return */ bit_count = 0; return_ptr = null; error_return_2: return_code = error_code; return; /* */ release: if bit_count >= 0 then /* set length only if bit count non-negative */ set_length: do; /* get the pathname so we can set bit count */ call hcs_$fs_get_path_name (seg_ptr, directory_name, len, entry_name, error_code); if error_code ^= 0 then goto error_return_2; /* set the bit count */ call hcs_$set_bc (directory_name, entry_name, bit_count, error_code); if error_code ^= 0 then return_code = error_code; /* truncate any unused pages */ word_count = divide (bit_count+35, 36, 24, 0); call hcs_$truncate_seg (seg_ptr, word_count, error_code); if error_code ^= 0 then return_code = error_code; if mod (bit_count, 36) ^= 0 then seg_ptr -> segment (word_count) = seg_ptr -> segment (word_count) & word_mask (mod (divide (bit_count+8, 9, 24, 0), 4)); end set_length; call hcs_$terminate_noname (seg_ptr, error_code); /* terminate the segment */ if error_code ^= 0 then goto error_return_2; /* */ end get_seg_ptr_;  teco.pl1 11/15/82 1907.0rew 11/15/82 1453.6 706824 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style3,^indattr,linecom,^indnoniterdo,indnoniterend,indcomtxt,indend,indcom,dclind5,idind23 */ TECO: teco: procedure; goto declarations; /**** This program was written by: Richard H. Gumpertz 4 Ames Street Cambridge, Mass. 02142 It is modelled after the TECO in use on the Digital Equipment Corp. PDP-10 which was originally written at the MIT Artificial Intelligence project. The syntax is as close to the PDP-10 syntax as the Multics environment will allow, with the one major exception being the file I/O commands. Dates modified and reasons: 07/08/82 by G. Palter to call cu_$evaluate_active_string instead of command_processor_$af 05/11/81 by C R Davis to fix bug in P command. 11/30/77 by David S. Levin: fix bug in n-command. 11/01/77 by David S. Levin: call command_processor_$af instead of command_processor_$return_val; and to print message if too many input args to teco. 07/27/77 by Larry Johnson for teco$set_prompt entry 07/30/76 by RGB: to add :J, :R, :C, :F<, F<, and F; 07/29/76 by RGB: to add :< (errset), :;, :"M, and :M 07/26/76 by RGB: to add "M command , := command, and :(backslash) command 07/26/76 by RGB: to ignore tabs between commands, to remove 7000 labels 07/24/76 by RGB: to add ea, to speed up, and to cleanup 06/21/76 by MJG: add P "append" request like X. 03/05/76 by DSL (& RGB): add teco$macro entry point;fix bug in -s;fix temp seg usage count for em. 04/23/75 by DSL: fix introduced bugs; use index and search bifs to speed scanning. 02/26/75 at 1238 by DSL: 1) add N-search; 2) use internal procedures; 3) bug fixes. 02/07/75 at 1622 by DSL to: 1) fix ; skip over >, 2) any length seg, 3) fast reverse searching, 4) fast \. 04/21/72 at 1900 by PBB to change teco_no_ES entry to just be another entry for teco that doesn't have the ES command implemented 04/21/72 at 1800 by PBB to fix bug in ES command 04/19/72 at 1300 by PBB to add ES command 03/25/72 at 1400 by PBB to make S with two args use arg1 as a line limit for search and :' to skip to the next ' - this makes :' an else command 03/25/72 at 1035 by PBB to make U with no args use 34359738367. 03/25/72 at 1005 by PBB to fix bugs in \ and improve error messages 03/24/72 at 1355 by PBB to fix bug in T command 03/23/72 at 1710 by PBB to add better error messages and prevent % from incrementing a text register 03/23/72 at 1230 by PBB to add backslash command 03/23/72 at 1030 by PBB to fix bug in g command when converting numeric register and to implement :T command 10/18/71 at 1245 by RHG to fix bug in restoring base_iteration_level in :X 07/21/71 at 0016 by RHG to fix bug in EO caused by separation out of EO_X_common (7/18/71) 07/18/71 at 1720 by RHG to use new get_temp_seg_ and to implement :X 07/10/71 at 1704 by RHG to call get_temporary_segment_ and release_temporary_segment_ to add more use of "hbound" builtin 06/29/71 at 0332 by RHG to rename startup as start_up 06/28/71 at 1434 by RHG to fix bug in EI//J, to allow command_buffer 100000 chars to put args in _r_e_a_l Q-registers. 06/28/71 at 0349 by RHG to fix bugs in EM, get_args, 0<..> 06/28/71 at 0052 by RHG to add EM, optimization of EI/name/J, startup EM, to allow quoted string in Q-register to move scratch_segment out to a temp seg to allow "%" to work on Q-register containing text 06/08/71 at 0145 by RHG to fix bugs in U, ?, and : 06/07/71 at 2335 by RHG to handle pl1_bug about char(262144) to allow commands within parentheses to implement get_character_fail_handler to allow U to take multiple arguments 02/18/71 at 1644 by RHG to fix the last fix to % 02/18/71 at 1459 by RHG to implement :VW and let U take 0 args 02/18/71 at 1429 by RHG to neaten file_errors 02/18/71 at 1408 by RHG to fix bug in question_mark 02/16/71 at 1326 by RHG to fix bug in % to use fixed_to_char_offset to use trace off during skip to call com_err_ on file errors 02/02/71 at 1325 by RHG to fix potential bug in O which unwinds 02/02/71 at 0337 by RHG to use the variable "max_Q_register_length" in :I to fix a bug in "revert_command_level" 02/02/71 at 0214 by RHG to allow O to unwind command level to make M at end of one macro do a "goto" not a "call" to fix a bug in M with no args 01/31/71 at 0510 by RHG to fix bug in get_character if only nl is typed 01/31/71 at 0230 by RHG to fix bug in :S and rename TED as TECO 01/25/72 at 1525 by RHG to fix bug in M 01/24/71 at 2305 by RHG to add the M, [, and ] commands 01/23/71 at 0300 by RHG to add the G, :I, X, VW, and ? commands earlier changes by RHG went unrecorded. ****/ /* condition names */ declare (cleanup, fixedoverflow, program_interrupt, teco_abort) condition; /* builtin functions */ declare (addr, bit, convert, copy, divide, fixed, hbound, index, lbound, length, max, min, multiply, null, reverse, search, substr, unspec, verify) builtin; /* automatic variables */ declare EO_X_common_return label variable; declare get_character_fail_handler label variable; declare (arg_address, b1, b2, command_line_address, file_address, io_char_address, p) pointer; declare 1 error_structure aligned, 2 error_message char (8), 2 nl char (1); declare cvb picture "(11)-9"; declare string char (12); declare (backup_flag, immediate_interrupt_ok, no_ES_flag, no_number, match, program_interrupt_flag, search_successful, trace_flag, trace_flag_copy) bit (1) aligned; declare my_id bit (36) aligned; declare (current_character, delimiter, io_char) char (1) aligned; declare search_chars char (2) aligned; declare (Q_register_pushdown_level, arg_length, command_level) fixed bin (17); declare arg1_stack (0:20) fixed bin (17); declare colon_stack (0:20) fixed bin (17); declare command_char_stack (0:20) fixed bin (17); declare command_iteration_stack (0:20) fixed bin (17); declare command_length_stack (0:20) fixed bin (17); declare command_seg_stack (0:20) fixed bin (17); declare macro_entry fixed bin (17); declare num_arg_stack (0:20) fixed bin (17); declare pushdown_Q_register_seg_number (1:20) fixed bin (17); declare pushdown_Q_register_value (1:20) fixed bin (17); declare arg (0:2) fixed bin (24); declare (backup_command_line_1_char, base_iteration_level, colon_X_save_command_level, colon_flag, tag_char_number, command_char_number, command_line_length, count, current_Q_register_number, current_expression, current_sign, dot1, dot2, end_buffer, i, iteration_level, return_iteration_level, j, max_seg_size, max_dot1, min_dot2, n1, n2, num_arg, number, octal_number, paren_level, start, read_count, search_answer, iteration_answer, search_length, skip_count, temp_dot, which_operator) fixed bin (24); declare expression_stack (1:20) fixed bin (24); declare operator_stack (1:20) fixed bin (24); declare sign_stack (1:20) fixed bin (24); declare error_code fixed bin (35); declare 1 iteration (1:20) aligned, 2 begin fixed bin (24), 2 end fixed bin (24), 2 count fixed bin (24), 2 begin_tag fixed bin (24), 2 errset bit (1); declare 1 temp_seg_info structure aligned, 2 Q_register_value (32:127) fixed bin (24), 2 Q_register_seg_number (32:127) fixed bin (17), 2 temp_seg_address (-100:100) pointer, 2 temp_seg_usage_count (-100:100) fixed bin (17); /* based variables */ declare argument based (arg_address) char (arg_length); declare current_Q_register based (current_Q_register_address) aligned char (current_Q_register_value); declare file based (file_address) aligned char (count); declare quoted_string based (quoted_string_address) aligned char (quoted_string_length); declare buffer1 based (b1) aligned char (dot1); declare buffer2 based (b2) aligned char (end_buffer); declare command_line based (command_line_address) aligned char (command_line_length); /* external entries */ declare assign_temp_seg_id_ entry (char (*) aligned, bit (36) aligned, fixed bin (35)); declare com_err_ entry options (variable); declare cu_$arg_count entry () returns (fixed bin (17)); declare cu_$arg_ptr entry (fixed bin (17), pointer, fixed bin (17), fixed bin (35)); declare cu_$cp entry (pointer, fixed bin (24), fixed bin (35)); declare cu_$ptr_call entry options (variable); declare cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed binary (24)); declare find_command_$fc_no_message entry (pointer, fixed bin (24), pointer, fixed bin (35)); declare get_seg_ptr_ entry (char (*) aligned, bit (6) aligned, fixed bin (24), pointer, fixed bin (35)); declare get_temp_seg_ entry (bit (36) aligned, bit (5) aligned, pointer, fixed bin (35)); declare ( ioa_, ioa_$rsnnl ) entry options (variable); declare iox_$get_chars entry (pointer, pointer, fixed bin (24), fixed bin (24), fixed bin (35)); declare iox_$get_line entry (pointer, pointer, fixed bin (24), fixed bin (24), fixed bin (35)); declare iox_$put_chars entry (pointer, pointer, fixed bin (24), fixed bin (35)); declare release_seg_ptr_ entry (pointer, fixed bin (17), fixed bin (35)); declare release_temp_segs_all_ entry (bit (36) aligned, fixed bin (35)); declare search_file_ entry (pointer, fixed bin (24), fixed bin (24), pointer, fixed bin (24), fixed bin (24), fixed bin (24), fixed bin (24), fixed bin (24)); declare teco_backup_file_ entry (char (*) aligned); declare teco_error entry (char (*) aligned); declare teco_get_macro_ entry (char (*) aligned, pointer, fixed bin (24), fixed bin (35)); /* defined variables */ declare current_Q_register_seg_number fixed bin (17) defined (Q_register_seg_number (current_Q_register_number)); declare current_Q_register_value fixed bin (24) defined (Q_register_value (current_Q_register_number)); declare current_Q_register_address pointer defined (temp_seg_address (current_Q_register_seg_number)); declare current_Q_register_usage_count fixed bin (17) defined (temp_seg_usage_count (current_Q_register_seg_number)); declare quoted_string_seg_number fixed bin (17) defined (Q_register_seg_number (34)); declare quoted_string_length fixed bin (24) defined (Q_register_value (34)); declare quoted_string_address pointer defined (temp_seg_address (Q_register_seg_number (34))); declare arg1 defined (arg (1)) fixed bin (24); declare arg2 defined (arg (2)) fixed bin (24); /* external static */ declare error_table_$too_many_args fixed bin (35) ext static; declare sys_info$max_seg_size external static fixed bin (24); declare iox_$user_input external static pointer; declare iox_$user_output external static pointer; /* constants */ declare new_line_char int static options (constant) char (1) aligned initial (" "); declare blanks int static options (constant) char (12) aligned initial (""); declare white_space int static options (constant) char (2) aligned initial (" "); /* space & tab */ declare start_up_name int static options (constant) char (8) aligned initial ("start_up"); declare char_0_code int static options (constant) fixed bin (09) initial (000110000b); declare dummy_Q_register_number int static options (constant) fixed bin (17) initial (127); declare number_reserved_temp_segs int static options (constant) fixed bin (17) initial (2); declare quoted_string_Q_register_number int static options (constant) fixed bin (17) initial (34); declare radix int static options (constant) fixed bin (17) initial (10); declare max_positive_integer int static options (constant) fixed bin (35) initial (11111111111111111111111111111111111b); declare rwa_access int static options (constant) bit (5) aligned initial ("01011"b); declare r_access int static options (constant) bit (6) aligned initial ("010000"b); declare rwac_access int static options (constant) bit (6) aligned initial ("010111"b); declare program_name int static options (constant) char (4) aligned initial ("teco"); /* internal static */ declare signature_length int static fixed bin (24) init (3); declare signature int static char (8) aligned initial ("NZ"); declare error_mode int static char (4) aligned initial ("shor"); %include cp_active_string_types; teco_error_mode: entry (new_error_mode); dcl new_error_mode char (*) unal; error_mode = new_error_mode; return; /* entry to set the prompt string */ set_prompt: entry; call cu_$arg_ptr (1, arg_address, arg_length, error_code); if error_code = 0 then do; signature = argument; signature_length = min (length (argument), length (signature)); end; else do; signature = "NZ"; signature_length = 3; end; return; teco_no_ES: entry; no_ES_flag = "1"b; macro_entry = 0; goto no_ES_declarations; abort: ABORT: entry; signal teco_abort; macro: entry; no_ES_flag = "0"b; macro_entry = 1; goto no_ES_declarations; declarations: no_ES_flag = "0"b; macro_entry = 0; no_ES_declarations: command_level = 0; Q_register_pushdown_level = 0; io_char_address = addr (io_char); error_structure.nl = new_line_char; unspec (temp_seg_info) = ""b; temp_seg_address (*) = null; /* If this is removed, the marked line */ /* in "allocate_Q_register" must be changed. */ max_seg_size = sys_info$max_seg_size * 4; read_count = cu_$arg_count (); /* If number of args exceeds size of pushdown stack, this invokation of teco is aborted. */ if read_count - macro_entry > hbound (pushdown_Q_register_value, 1) - 1 then do; call com_err_ (error_table_$too_many_args, program_name, "Maximum number of arguments is ^d.", hbound (pushdown_Q_register_value, 1) - 1); return; end; call assign_temp_seg_id_ (program_name, my_id, error_code); if error_code ^= 0 then do; call com_err_ (error_code, program_name, "temporary_segment_id"); return; end; on cleanup call release_bufs; do i = 0 to number_reserved_temp_segs + (read_count - macro_entry) + 1; call get_temp_seg_ (my_id, rwa_access, p, error_code); if error_code ^= 0 then do; call com_err_ (error_code, program_name, "temporary segment number ^d", (i)); goto EQ; end; temp_seg_address (i) = p; end; command_line_address = temp_seg_address (0); Q_register_pushdown_level = (read_count - macro_entry) + 1; pushdown_Q_register_seg_number (Q_register_pushdown_level) = 0; pushdown_Q_register_value (Q_register_pushdown_level) = (read_count - macro_entry); do i = 1 to read_count - macro_entry; call cu_$arg_ptr (read_count - i + 1, arg_address, arg_length, error_code); temp_seg_address (i + 3) -> argument = arg_address -> argument; temp_seg_usage_count (i + 3) = 1; pushdown_Q_register_value (i) = arg_length; pushdown_Q_register_seg_number (i) = i + 3; end; command_seg_stack (0) = -1; temp_seg_usage_count (-1) = 1; temp_seg_address (-1) = command_line_address; quoted_string_seg_number = 3; temp_seg_usage_count (3) = 1; n1, n2 = 0; b1 = null; dot1, dot2, end_buffer = 0; max_dot1, min_dot2 = 0; base_iteration_level = 0; paren_level = 0; trace_flag, trace_flag_copy = "0"b; command_char_number, command_line_length, backup_command_line_1_char = 0; search_answer = 0; iteration_level = 0; immediate_interrupt_ok = "1"b; num_arg = 0; colon_flag = 0; which_operator = -1; program_interrupt_flag = "0"b; on program_interrupt begin; if immediate_interrupt_ok then goto command_abort; else program_interrupt_flag = "1"b; end; on teco_abort goto command_abort; current_Q_register_number = quoted_string_Q_register_number; /* determine initial macro. */ if macro_entry = 0 /* Use default. */ then do; quoted_string_length = length (start_up_name); quoted_string = start_up_name; end; else do; call cu_$arg_ptr (1, arg_address, arg_length, error_code); if error_code ^= 0 then do; call com_err_ (error_code, program_name); goto EQ; end; quoted_string_length = arg_length; quoted_string = arg_address -> argument; end; goto EM_have_name; command_abort: program_interrupt_flag = "0"b; immediate_interrupt_ok = "0"b; do while (command_level > 0); /* Handle each command level separately. */ call unwind_command_level; end; base_iteration_level, iteration_level = 0; paren_level = 0; command_line_length, backup_command_line_1_char = 0; if macro_entry ^= 0 /* Error while in macro mode is fatal. */ then do; call com_err_ (0, program_name, "Command aborted."); goto EQ; end; trace_flag = trace_flag_copy; command_complete: COMMAND (36): COMMAND (10): /* NEWLINE and $ - Do Nothing */ num_arg = 0; command_return_value: colon_flag = 0; if num_arg = 0 then new_arg: which_operator = -1; else arg_loop: which_operator = 0; M_return: if program_interrupt_flag then goto command_abort; immediate_interrupt_ok = "1"b; get_character_fail_handler = command_string_completed; get_number: /* computes number, current_sign, no_number */ current_sign = 0; number = 0; no_number = "0"b; COMMAND_PREFIX (1): COMMAND_PREFIX (24): /* Blank and Tab - ignored between commands */ continue_scan: call get_character; goto COMMAND_PREFIX (index (" (:?0123456789-.zZqQ%bB ", current_character)); COMMAND_PREFIX (0): /* Not a Numeric Argument */ if current_sign = 0 then if which_operator < 0 then goto check_command; else if which_operator = 0 then goto check_operator; number = 1; no_number = "1"b; backup_com_line: backup_command_line_1_char = 1; got_number: COMMAND_PREFIX (22): COMMAND_PREFIX (23): /* B - Note: value all set */ if current_sign < 0 then number = -number; goto OPERATOR (which_operator); command_string_completed: if iteration_level ^= 0 then goto unfinished_iteration; if paren_level ^= 0 then goto unbalanced_parentheses; macro_entry = 0; /* If we reach teco cmd level, macro mode is ended. */ if signature_length > 0 then call WRITE (addr (signature), 0, signature_length); do while (Q_register_pushdown_level ^= 0); Q_register_pushdown_level = Q_register_pushdown_level - 1; temp_seg_usage_count (pushdown_Q_register_seg_number (Q_register_pushdown_level + 1)) = temp_seg_usage_count (pushdown_Q_register_seg_number (Q_register_pushdown_level + 1)) - 1; end; command_line_length = 0; command_char_number = 0; search_answer = 0; call read_line; go to command_complete; COMMAND_PREFIX (15): if which_operator = 0 then goto COMMAND_PREFIX (0); /* unary minus */ current_sign = -current_sign; if current_sign = 0 then current_sign = -1; goto continue_scan; COMMAND (43): /* Leading Plus */ current_sign = 1; goto continue_scan; COMMAND_PREFIX (5): COMMAND_PREFIX (6): COMMAND_PREFIX (7): COMMAND_PREFIX (8): COMMAND_PREFIX (9): COMMAND_PREFIX (10): COMMAND_PREFIX (11): COMMAND_PREFIX (12): COMMAND_PREFIX (13): COMMAND_PREFIX (14): /* 0,1,2,3,4,5,6,7,8,9 */ octal_number = 0; do i = fixed (unspec (io_char), 9, 0) - char_0_code repeat (fixed (unspec (io_char), 9, 0) - char_0_code) while (i >= 0 & i < radix); number = multiply (number, radix, 15, 0) + i; octal_number = octal_number * 8 + i; call get_character; end; if current_character ^= "." then goto backup_com_line; number = octal_number; goto got_number; COMMAND_PREFIX (16): /* . - Get Dot Value */ number = dot1; goto got_number; COMMAND_PREFIX (17): COMMAND_PREFIX (18): /* Z - End Value */ number = dot1 + end_buffer - dot2; goto got_number; COMMAND_PREFIX (19): COMMAND_PREFIX (20): /* Q - Q Register value */ current_Q_register_number = get_Q_register_number (); number = current_Q_register_value; goto got_number; COMMAND_PREFIX (21): /* % - Increment Command */ current_Q_register_number = get_Q_register_number (); if current_Q_register_seg_number ^= 0 then goto percent_cant_increment; current_Q_register_value, number = current_Q_register_value + 1; goto got_number; COMMAND_PREFIX (3): /* : - Command Modifier */ colon_flag = 1; goto continue_scan; COMMAND_PREFIX (4): /* ? - Trace */ trace_flag = "1"b; get_character_fail_handler = question_mark_alone; call get_character; if current_character = "?" then trace_flag = "0"b; else backup_command_line_1_char = 1; question_mark_alone: trace_flag_copy = trace_flag; get_character_fail_handler = command_string_completed; goto continue_scan; OPERATOR (-1): which_operator = 0; two_commas: if num_arg >= hbound (arg, 1) then goto too_many_args; num_arg = num_arg + 1; current_expression = number; goto arg_loop; OPERATOR (0): OPERATOR (1): current_expression = current_expression + number; goto arg_loop; OPERATOR (2): current_expression = current_expression - number; goto arg_loop; OPERATOR (3): if no_number then goto missing_right_operand; current_expression = current_expression * number; goto arg_loop; OPERATOR (4): if no_number then goto missing_right_operand; current_expression = divide (current_expression, number, 15, 0); goto arg_loop; OPERATOR (5): if no_number then goto missing_right_operand; unspec (current_expression) = unspec (current_expression) & unspec (number); goto arg_loop; OPERATOR (6): if no_number then goto missing_right_operand; unspec (current_expression) = unspec (current_expression) | unspec (number); goto arg_loop; COMMAND_PREFIX (2): /* ( */ if paren_level >= hbound (expression_stack, 1) then goto parenthesis_overflow; operator_stack (paren_level + 1) = which_operator; sign_stack (paren_level + 1) = current_sign; expression_stack (paren_level + 1) = current_expression; num_arg_stack (paren_level + 1) = num_arg; colon_stack (paren_level + 1) = colon_flag; arg1_stack (paren_level + 1) = arg1; /* we don't have to save arg2 because max 2 args anyways */ paren_level = paren_level + 1; goto command_complete; COMMAND (41): /* ) */ if paren_level = 0 then goto unbalanced_parentheses; if num_arg >= 2 then goto strange_parentheses; paren_level = paren_level - 1; number = arg1; which_operator = operator_stack (paren_level + 1); current_sign = sign_stack (paren_level + 1); current_expression = expression_stack (paren_level + 1); arg1 = arg1_stack (paren_level + 1); colon_flag = colon_stack (paren_level + 1); i = num_arg; num_arg = num_arg_stack (paren_level + 1); if i = 0 then goto get_number; goto got_number; check_operator: /* OPERATOR DISPATCH */ which_operator = index ("+-*/&|", current_character); if which_operator ^= 0 then goto get_number; check_command: /* COMMAND DISPATCH */ arg (num_arg) = current_expression; goto COMMAND (fixed (unspec (current_character) & "001111111"b, 9)); COMMAND (44): /* , - Next Argument Separator */ if which_operator >= 0 then goto new_arg; number = 0; goto two_commas; COMMAND (61): /* = - Print Value Command */ if colon_flag = 1 then call ioa_ ("^v(^o^x^)", num_arg, arg1, arg2); else call ioa_ ("^v(^d^x^)", num_arg, arg1, arg2); goto command_complete; COMMAND (60): /* < - Open Iteration */ tag_char_number = 0; iteration_common: if num_arg >= 2 then goto too_many_args; if num_arg = 0 then arg1 = max_positive_integer; if arg1 < 0 then goto bad_negative_argument; if iteration_level >= hbound (iteration.count, 1) then goto iteration_overflow; iteration.errset (iteration_level + 1) = (colon_flag ^= 0); iteration.begin_tag (iteration_level + 1) = tag_char_number; if arg1 = 0 then do; call skip ("<>"); goto iteration_done; end; iteration_level = iteration_level + 1; iteration.begin (iteration_level) = command_char_number; iteration.end (iteration_level) = -1; iteration.count (iteration_level) = arg1; goto command_complete; COMMAND (62): /* > - End Iteration */ if num_arg ^= 0 then goto too_many_args; if iteration_level = base_iteration_level then goto iteration_underflow; iteration.count (iteration_level) = iteration.count (iteration_level) - 1; if iteration.count (iteration_level) ^= 0 then do; iteration.end (iteration_level) = command_char_number; command_char_number = iteration.begin (iteration_level); goto command_complete; end; iteration_level = iteration_level - 1; iteration_done: iteration_answer = -1; /* succeed */ get_out_of_iteration: if iteration.errset (iteration_level + 1) | iteration.begin_tag (iteration_level + 1) ^= 0 then do; num_arg = 1; current_expression = iteration_answer; goto command_return_value; end; else goto command_complete; COMMAND (59): /* ; - Return if Positive */ if num_arg >= 2 then goto too_many_args; if iteration_level = 0 then goto semi_colon_out_of_iteration; if num_arg = 0 then arg1 = search_answer; if colon_flag = 0 then if arg1 < 0 then goto command_complete; else ; else if arg1 >= 0 then goto command_complete; call unwind_iteration (iteration_level - 1); goto iteration_done; COMMAND (34): /* " - Quote Command Dispatch */ if num_arg >= 3 then goto too_many_args; if num_arg = 1 then arg2 = 0; get_character_fail_handler = missing_double_quote_command; call get_character; goto QUOTE_COMMAND (index ("cCeEgGlLnNmM", current_character)); QUOTE_COMMAND (1): QUOTE_COMMAND (2): /* "C */ if num_arg = 0 then goto too_few_args; if num_arg = 2 then goto too_many_args; unspec (io_char) = bit (fixed (arg1, 9, 0)); if io_char >= "a" then if io_char <= "z" then goto command_complete; if io_char >= "A" then if io_char <= "Z" then goto command_complete; if io_char >= "0" then if io_char <= "9" then goto command_complete; if io_char = "_" then goto command_complete; if io_char = "$" then goto command_complete; if io_char = "." then goto command_complete; goto quote_skip; QUOTE_COMMAND (3): QUOTE_COMMAND (4): /* "E Equal Command */ if num_arg = 0 then goto too_few_args; if arg1 = arg2 then goto command_complete; else goto quote_skip; QUOTE_COMMAND (5): QUOTE_COMMAND (6): /* "G - Greater Than Command */ if num_arg = 0 then goto too_few_args; if arg1 > arg2 then goto command_complete; else goto quote_skip; QUOTE_COMMAND (7): QUOTE_COMMAND (8): /* "L - Less Than Command */ if num_arg = 0 then goto too_few_args; if arg1 < arg2 then goto command_complete; else goto quote_skip; QUOTE_COMMAND (9): QUOTE_COMMAND (10): /* "N - Not Equal Command */ if num_arg = 0 then goto too_few_args; if arg1 ^= arg2 then goto command_complete; else goto quote_skip; QUOTE_COMMAND (11): QUOTE_COMMAND (12): /* "M - Match String Command */ if num_arg ^= 0 then goto too_many_args; call get_quoted_string; if end_buffer - dot2 < quoted_string_length then match = "0"b; else match = quoted_string = substr (buffer2, dot2 + 1, quoted_string_length); if colon_flag ^= 0 then match = ^match; if match then goto command_complete; else goto quote_skip; quote_skip: call skip ("""'"); goto command_complete; COMMAND (39): /* ' - Apostrophe */ if colon_flag = 1 then goto quote_skip; /* a :' forms an else statement */ goto command_complete; /* Ignore any apostrophes we are just passing by. */ COMMAND (33): /* ! - Label Delimiter */ call skip_with_trace ("!!"); goto command_complete; COMMAND (91): /* [ - Push */ if Q_register_pushdown_level >= hbound (pushdown_Q_register_value, 1) then goto Q_register_pushdown_overflow; current_Q_register_number = get_Q_register_number (); pushdown_Q_register_value (Q_register_pushdown_level + 1) = current_Q_register_value; pushdown_Q_register_seg_number (Q_register_pushdown_level + 1) = current_Q_register_seg_number; immediate_interrupt_ok = "0"b; if current_Q_register_seg_number ^= 0 then current_Q_register_usage_count = current_Q_register_usage_count + 1; Q_register_pushdown_level = Q_register_pushdown_level + 1; goto command_complete; COMMAND (93): /* ] - Pop */ if Q_register_pushdown_level = 0 then goto Q_register_pushdown_underflow; current_Q_register_number = get_Q_register_number (); i = current_Q_register_seg_number; immediate_interrupt_ok = "0"b; Q_register_pushdown_level = Q_register_pushdown_level - 1; current_Q_register_value = pushdown_Q_register_value (Q_register_pushdown_level + 1); current_Q_register_seg_number = pushdown_Q_register_seg_number (Q_register_pushdown_level + 1); if i ^= 0 then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1; goto command_complete; COMMAND (65): COMMAND (97): /* A - Ascii Command */ if num_arg >= 2 then goto too_many_args; if num_arg = 0 then goto unimplemented_feature; if arg1 > 0 then do; i = dot2 + arg1 - 1; if i >= end_buffer then goto A_1_arg_beyond_Z; io_char = substr (buffer2, i + 1, 1); end; else do; i = dot1 + arg1 - 1; if i < 0 then goto A_1_arg_before_0; io_char = substr (buffer1, i + 1, 1); end; current_expression = fixed (unspec (io_char), 9, 0); num_arg = 1; goto command_return_value; COMMAND (67): COMMAND (99): /* C - Characters Forward Command */ if num_arg = 0 then arg1 = 1; C_check: if num_arg > 1 then goto too_many_args; call move_dot (arg1, (colon_flag ^= 0)); goto command_complete; COMMAND (68): COMMAND (100): if num_arg = 0 then arg1 = 1; /* D - Delete */ if num_arg >= 2 then goto too_many_args; call delete_chars (min (dot1, dot1 + arg1), max (dot2, dot2 + arg1)); goto command_complete; COMMAND (69): COMMAND (101): /* E command dispach */ get_character_fail_handler = EXTERNAL_COMMAND (0); call get_character; goto EXTERNAL_COMMAND (index ("oOiImMcCaAsSbBgGqQ", current_character)); EXTERNAL_COMMAND (9): EXTERNAL_COMMAND (10): /* EA - External Active Function */ dcl ret_string char (10000) varying based (current_Q_register_address), cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)); current_Q_register_number = get_Q_register_number (); call get_quoted_string; call allocate_Q_register_have_number (current_Q_register_number); ret_string = ""; begin; dcl quoted_string_unal char (quoted_string_length) based (quoted_string_address); call cu_$evaluate_active_string (null (), quoted_string_unal, NORMAL_ACTIVE_STRING, ret_string, error_code) ; end; if error_code ^= 0 then do; call com_err_ (error_code, program_name, """^a""", quoted_string); goto command_abort; end; current_Q_register_value = length (ret_string); current_Q_register = copy (ret_string, 1); goto command_complete; EXTERNAL_COMMAND (13): EXTERNAL_COMMAND (14): /* EB - External Backup */ backup_flag = "1"b; goto EO_EB_common; EXTERNAL_COMMAND (7): EXTERNAL_COMMAND (8): /* EC - External Command */ call get_quoted_string; call cu_$cp (quoted_string_address, quoted_string_length, error_code); goto command_complete; EXTERNAL_COMMAND (15): EXTERNAL_COMMAND (16): /* EG - ??? */ goto unimplemented_feature; EXTERNAL_COMMAND (3): EXTERNAL_COMMAND (4): /* EI - External Input */ if num_arg ^= 0 then goto too_many_args; num_arg = colon_flag; /* indicate if returning a value */ call get_quoted_string; call get_seg_ptr_ (quoted_string, r_access, read_count, file_address, error_code); if error_code ^= 0 then if colon_flag = 1 then do; current_expression = 0; /* fail */ goto command_return_value; end; else goto file_error; count = divide (read_count + 8, 9, 17, 0); if dot1 + end_buffer - dot2 > 0 /* Text in buffer, cannot use source seg. */ then do; call add_chars (file_address, count); call close_file (file_address); end; else do; /* Buffer is empty, don't copy, use source seg. */ immediate_interrupt_ok = "0"b; b1, b2 = file_address; n1, n2 = 0; dot1, dot2, end_buffer, max_dot1 = count; min_dot2 = 0; end; if colon_flag = 1 then do; current_expression = -1; /* good */ goto command_return_value; end; else goto command_complete; EXTERNAL_COMMAND (5): EXTERNAL_COMMAND (6): /* EM - External Macro */ call get_quoted_string; EM_have_name: call teco_get_macro_ (quoted_string, file_address, read_count, error_code); if error_code ^= 0 then goto EM_macro_not_found; j = 0; do i = -1 to lbound (temp_seg_address, 1) by -1; if temp_seg_address (i) = file_address then goto EM_have_slot; if j = 0 then if temp_seg_usage_count (i) = 0 then j = i; end; if j = 0 then goto EM_no_slot; i = j; EM_have_slot: temp_seg_address (i) = file_address; current_Q_register_number = dummy_Q_register_number; Q_register_value (dummy_Q_register_number) = read_count; Q_register_seg_number (dummy_Q_register_number) = i; goto M_have_reg; EXTERNAL_COMMAND (1): EXTERNAL_COMMAND (2): /* EO - External Output */ backup_flag = "0"b; EO_EB_common: if num_arg >= 3 then goto too_many_args; do; call get_quoted_string; if backup_flag then call teco_backup_file_ (quoted_string); call get_seg_ptr_ (quoted_string, rwac_access, read_count, file_address, error_code); if file_address = null then goto file_error; end; immediate_interrupt_ok = "0"b; if b1 = file_address then call copy_source; start = 1; EO_X_common_return = EO_close_file; if num_arg ^= 0 then goto EO_X_common; else do; arg1 = 0; count = dot1 + end_buffer - dot2; goto EO_X_around_dot; end; EO_close_file: call release_seg_ptr_ (file_address, 9 * count, error_code); if error_code ^= 0 then goto file_error; goto command_complete; EO_X_common: if num_arg < 2 then if arg1 >= 1 then do; call find_line_forward; arg1 = dot1; goto EO_X_after_dot; end; else do; call find_line_reverse; arg1 = temp_dot; count = dot1 - temp_dot; goto EO_X_before_dot; end; else do; /* (num_arg = 2) */ if arg1 < 0 then arg1 = 0; if arg2 > dot1 + end_buffer - dot2 then arg2 = dot1 + end_buffer - dot2; count = arg2 - arg1; if count < 0 then goto args_wrong_order; if start + count > max_seg_size then goto dot_beyond_Z; /* will overflow Q reg */ if dot1 >= arg2 then EO_X_before_dot: do; if count ^= 0 then substr (file, start, count) = substr (buffer1, arg1 + 1, count); goto EO_X_common_return; end; if arg1 >= dot1 then EO_X_after_dot: do; if count ^= 0 then substr (file, start, count) = substr (buffer2, (arg1 + dot2 - dot1) + 1, count); goto EO_X_common_return; end; else /* (arg1<. 1 then goto too_many_args; if num_arg < 1 then goto too_few_args; call get_quoted_string; if iteration_level = 0 then goto semi_colon_out_of_iteration; do return_iteration_level = iteration_level by -1 to 1; do while (return_iteration_level <= base_iteration_level); call unwind_command_level; end; if iteration.begin_tag (return_iteration_level) ^= 0 then if quoted_string = substr (command_line, iteration.begin_tag (return_iteration_level) + 1, iteration.begin (return_iteration_level) - 1 - iteration.begin_tag (return_iteration_level)) then do; call unwind_iteration (return_iteration_level - 1); iteration_answer = arg1; goto get_out_of_iteration; end; end; goto label_not_found; COMMAND (71): COMMAND (103): /* G - Get Q Register Command */ if num_arg ^= 0 then goto too_many_args; current_Q_register_number = get_Q_register_number (); if current_Q_register_seg_number ^= 0 then do; call add_chars (current_Q_register_address, current_Q_register_value); goto command_complete; end; else do; /* (Q_reg contains a number -- convert it to text) */ num_arg = 1; arg1 = current_Q_register_value; goto backslash; end; COMMAND (72): COMMAND (104): /* H - wHole Syntax Krock */ if num_arg ^= 0 then goto too_many_args; arg1 = 0; current_expression = dot1 + end_buffer - dot2; num_arg = 2; goto command_return_value; COMMAND (73): COMMAND (105): /* I - Insert Command */ if num_arg >= 2 then goto too_many_args; if colon_flag = 0 then do; if num_arg = 0 then do; call get_quoted_string; call add_chars (quoted_string_address, quoted_string_length); goto command_complete; end; else do; unspec (io_char) = bit (fixed (arg1, 9, 0)); call add_chars (io_char_address, 1); goto command_complete; end; end; else do; current_Q_register_number = get_Q_register_number (); if num_arg = 0 then do; call get_quoted_string; immediate_interrupt_ok = "0"b; temp_seg_usage_count (quoted_string_seg_number) = temp_seg_usage_count (quoted_string_seg_number) + 1; i = current_Q_register_seg_number; current_Q_register_seg_number = quoted_string_seg_number; current_Q_register_value = quoted_string_length; if i ^= 0 then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1; goto command_complete; end; else do; immediate_interrupt_ok = "0"b; call allocate_Q_register_have_number (current_Q_register_number); unspec (substr (current_Q_register_address -> file, 1, 1)) = bit (fixed (arg1, 9, 0)); current_Q_register_value = 1; goto command_complete; end; end; COMMAND (74): COMMAND (106): /* J- Jump Command */ if num_arg = 0 then arg1 = 0; arg1 = arg1 - dot1; goto C_check; COMMAND (75): COMMAND (107): /* K - Kill Command */ if num_arg > 2 then goto too_many_args; if num_arg < 2 then do; if num_arg = 0 then arg1 = 1; if arg1 > 0 then do; call must_find_line_forward; call delete_chars (dot1, temp_dot); goto command_complete; end; else do; call must_find_line_reverse; call delete_chars (temp_dot, dot2); goto command_complete; end; end; if arg1 > arg2 then goto args_wrong_order; call move_dot_forward (arg1 - dot1); /* If dot < arg1; move dot to arg1, else no move. */ call move_dot_backward (arg2 - dot1); /* If arg2 < dot; move dot to arg2, else no move. */ call delete_chars (arg1, dot2 + arg2 - dot1); goto command_complete; COMMAND (76): COMMAND (108): /* L - Lines Command */ if num_arg > 1 then goto too_many_args; if num_arg = 0 then arg1 = 1; if arg1 > 0 then do; call must_find_line_forward; call move_dot_forward (count - colon_flag); end; else do; call must_find_line_reverse; call move_dot_backward (temp_dot - dot1 - colon_flag); end; goto command_complete; COMMAND (77): COMMAND (109): /* M - Macro Command */ current_Q_register_number = get_Q_register_number (); if current_Q_register_seg_number = 0 then goto M_numeric_Q_register; M_have_reg: if (command_level ^= 0 & command_char_number = command_line_length) | colon_flag ^= 0 then do; call revert_command_level; goto M_get_new_line; end; if command_level >= hbound (command_char_stack, 1) then goto command_level_overflow; command_char_stack (command_level) = command_char_number; command_length_stack (command_level) = command_line_length; command_iteration_stack (command_level) = base_iteration_level; M_get_new_line: command_seg_stack (command_level + 1) = current_Q_register_seg_number; immediate_interrupt_ok = "0"b; command_line_length = current_Q_register_value; current_Q_register_usage_count = current_Q_register_usage_count + 1; command_line_address = current_Q_register_address; command_char_number = 0; base_iteration_level = iteration_level; command_level = command_level + 1; goto M_return; COMMAND (78): COMMAND (110): /* N - QEDX type string search. Sets Q". */ if num_arg = 0 then arg1 = 1; /* default is one forward search. */ if num_arg > 2 then goto too_many_args; if num_arg = 2 /* arg1- line count; arg2- search count. */ then do; if arg1 <= 0 | arg2 < 0 then goto unimplemented_feature; /* Can't reverse regular expr. */ call find_line_forward; arg1 = arg2; /* make it look like one arg case. */ arg2 = temp_dot; /* Set search limit. */ end; else if arg1 >= 0 /* One arg. arg1- search count. */ then arg2 = end_buffer; /* Search remainder by default. */ else goto unimplemented_feature; /* Can't reverse regular expr. */ num_arg = colon_flag; /* Indicate whether we return a value. */ call get_quoted_string; /* Get the regular expr. */ if quoted_string_length = 0 then goto command_complete; /* Zero len string matches anything. */ if arg1 = 0 then goto command_complete; /* search count = 0. */ temp_dot = dot2; i = quoted_string_length; if n1 ^= n2 /* search_file_ requires context for its search. */ then if dot1 > 0 /* Move char only if there is one. */ then do; /* Copy one character from before dot. */ call move_dot_backward (-1); /* This should handle exceptional cases. */ dot1 = dot1 + 1; /* This should be transparent. */ dot2 = dot2 + 1; /* This should be transparent. */ end; else if dot2 > 0 /* Must convince search_file_ we have beginning of line. */ then substr (buffer2, dot2, 1) = new_line_char; /* search_file_ knows about offsets. */ do arg1 = 1 to arg1; if temp_dot >= arg2 then goto S_fail; call search_file_ (quoted_string_address, 1, i, b2, temp_dot + 1, arg2, j, temp_dot, count); if count ^= 0 then do; current_Q_register_number = quoted_string_Q_register_number; call allocate_Q_register_have_number (current_Q_register_number); quoted_string_length = 0; goto S_fail; end; i = 0; /* Speed up search time. */ end; current_Q_register_number = quoted_string_Q_register_number; call allocate_Q_register_have_number (current_Q_register_number); count = temp_dot - j + 1; /* Length of matched string. */ if count = 0 then goto S_succeed_forward; substr (quoted_string, 1, count) = substr (buffer2, j, count); quoted_string_length = count; goto S_succeed_forward; COMMAND (79): COMMAND (111): /* O - gOto Command */ call get_quoted_string; count = quoted_string_length + 1; substr (quoted_string, count, 1) = "!"; O_have_label: command_char_number = 1; do while ("1"b); if command_char_number + count >= command_line_length then goto O_unwind_command; i = index (substr (command_line, command_char_number + 1), substr (quoted_string, 1, count)); if i = 0 then O_unwind_command: do; if command_level = 0 then goto label_not_found; call revert_command_level; goto O_have_label; end O_unwind_command; command_char_number = command_char_number + i + quoted_string_length; if substr (command_line, command_char_number - count, 1) = "!" then goto command_complete; end; COMMAND (80): COMMAND (112): /* P - aPpend to Q Register */ immediate_interrupt_ok = "0"b; current_Q_register_number = get_Q_register_number (); if num_arg = 0 then arg1 = 1; if current_Q_register_seg_number ^= 0 then do; if current_Q_register_usage_count > 1 then do; file_address = current_Q_register_address; count = current_Q_register_value; call allocate_Q_register_have_number (current_Q_register_number); current_Q_register_value = count; current_Q_register = file; /* Copy the string */ end; file_address = current_Q_register_address; start = current_Q_register_value + 1; EO_X_common_return = normal_P_close_Q_reg; goto EO_X_common; normal_P_close_Q_reg: current_Q_register_value = current_Q_register_value + count; end; else do; call allocate_Q_register_have_number (current_Q_register_number); file_address = current_Q_register_address; EO_X_common_return = null_P_close_Q_reg; start = 1; goto EO_X_common; null_P_close_Q_reg: current_Q_register_value = count; end; goto command_complete; COMMAND (82): COMMAND (114): /* R - Reverse Characters */ if num_arg = 0 then arg1 = 1; arg1 = -arg1; goto C_check; COMMAND (83): COMMAND (115): do; /* S - Search Text */ if num_arg = 0 then arg1 = 1; if num_arg > 2 then goto too_many_args; if num_arg = 2 then do; if arg1 >= 1 /* arg1 is the number of lines to search over */ then do; if arg2 < 0 then goto S_fail; call find_line_forward; end; else do; if arg2 > 0 then goto S_fail; call find_line_reverse; end; arg1 = arg2; /* move search count to arg1. */ arg2 = temp_dot; /* put search limit in arg2. */ end; else /* num_arg < 2 */ if arg1 >= 0 then arg2 = end_buffer; else arg2 = 0; num_arg = colon_flag; /* indicate whether a value is being returned or not */ do; call get_quoted_string; if quoted_string_length = 0 then goto command_complete; if arg1 = 0 then goto command_complete; if arg1 >= 0 then do; temp_dot = dot2; plus_S_loop: do; if arg2 = temp_dot then goto S_fail; j = index (substr (buffer2, temp_dot + 1, arg2 - temp_dot), quoted_string); if j = 0 then S_fail: do; search_answer = 0; if colon_flag = 0 then goto fatal_S_fail; else do; current_expression = search_answer; goto command_return_value; end; end S_fail; temp_dot = temp_dot + (j - 1 + quoted_string_length); arg1 = arg1 - 1; if arg1 ^= 0 then goto plus_S_loop; end plus_S_loop; S_succeed_forward: arg1 = temp_dot - dot2; S_succeed: search_answer = -1; current_expression = search_answer; call move_dot (arg1, "0"b); goto command_return_value; end; /* Minus search is done in line. The following code takes advantage of the PL/I compiler's optimizer. */ /* index(reverse(substr(something)), reverse(char_1_or_2)) is inline if char_1_or_2 is aligned & constant length. */ /* Also, the reverse(substr(something)) does not move any characters. */ else do; /* (arg1 < 0) */ temp_dot = dot1; search_chars = substr (quoted_string, 1, 2); if quoted_string_length = 1 then do while (arg1 < 0); if temp_dot = arg2 then goto S_fail; j = index (reverse (substr (buffer1, arg2 + 1, temp_dot - arg2)), substr (search_chars, 1, 1)); if j = 0 then goto S_fail; temp_dot = temp_dot - j; arg1 = arg1 + 1; end; else do; minus_S_iterate: if temp_dot - arg2 < 2 then go to S_fail; /* Must have room to search. */ j = index (reverse (substr (buffer1, arg2 + 1, temp_dot - arg2)), reverse (search_chars)); if j = 0 then go to S_fail; temp_dot = temp_dot - j; if (temp_dot - 1) + quoted_string_length > dot1 then go to minus_S_iterate; if quoted_string_length > 2 then if substr (buffer1, temp_dot + 2, quoted_string_length - 2) ^= substr (quoted_string, 3, quoted_string_length - 2) then goto minus_S_iterate; temp_dot = temp_dot - 1; arg1 = arg1 + 1; if arg1 < 0 then goto minus_S_iterate; end; arg1 = temp_dot - dot1; goto S_succeed; end; end; end; COMMAND (84): COMMAND (116): /* T - Type Text */ if colon_flag = 0 then do; if num_arg = 0 then arg1 = 1; if num_arg > 2 then goto too_many_args; if num_arg < 2 then if arg1 >= 1 then do; call find_line_forward; arg1 = dot1; arg2 = dot1 + count; end; else /* (arg1 < 1) */ do; call find_line_reverse; arg1 = temp_dot; arg2 = dot1; end; else do; /* (num_arg = 2) */ if arg1 < 0 then arg1 = 0; if arg2 > dot1 + end_buffer - dot2 then arg2 = dot1 + end_buffer - dot2; end; count = arg2 - arg1; if count < 0 then goto args_wrong_order; if count = 0 then goto command_complete; i = arg2 - dot1; /* Number of characters after DOT. */ j = dot1 - arg1; /* Number of characters before DOT. */ if j > 0 /* Print characters before DOT. */ then do; j = 0; /* In case there are characters after DOT. */ if i < 0 then i = 0; /* Negative numbers don't work. */ call WRITE (b1, arg1, count - i); end; if i > 0 then call WRITE (b2, dot2 - j, i + j); goto command_complete; end; else do; /* (colon_flag = 1) */ if num_arg ^= 0 then goto too_many_args; call get_quoted_string; call WRITE (quoted_string_address, 0, quoted_string_length); goto command_complete; end; COMMAND (85): COMMAND (117): /* U - Update Q Register */ current_Q_register_number = get_Q_register_number (); immediate_interrupt_ok = "0"b; i = current_Q_register_seg_number; current_Q_register_seg_number = 0; if num_arg = 0 then do; num_arg = 1; arg1 = max_positive_integer; end; current_Q_register_value = arg (num_arg); if i ^= 0 then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1; num_arg = num_arg - 1; current_expression = arg (num_arg); goto command_return_value; COMMAND (86): COMMAND (118): /* V - who knows? */ /* V not implemented, but let VW work anyways */ get_character_fail_handler = command_complete; call get_character; if current_character = "w" then goto VW; if current_character = "W" then goto VW; backup_command_line_1_char = 1; goto command_complete; VW: if colon_flag = 0 then do; call READ_CHAR; current_expression = fixed (unspec (io_char), 9, 0); num_arg = 1; goto command_return_value; end; else do; call allocate_Q_register (current_Q_register_number); call READ (current_Q_register_address, 0); current_Q_register_value = read_count; goto command_complete; end; COMMAND (87): COMMAND (119): goto command_complete; /* W - Wipe */ COMMAND (88): COMMAND (120): /* X - eXtract to Q Register */ if colon_flag = 0 then do; if num_arg = 0 then arg1 = 1; immediate_interrupt_ok = "0"b; call allocate_Q_register (current_Q_register_number); file_address = current_Q_register_address; EO_X_common_return = normal_X_close_Q_register; start = 1; goto EO_X_common; normal_X_close_Q_register: current_Q_register_value = count; goto command_complete; end; else do; if num_arg ^= 0 then goto too_many_args; current_Q_register_number = get_Q_register_number (); if command_level = 0 then goto colon_X_not_in_macro; colon_X_save_command_level = command_level; command_char_stack (command_level) = command_char_number; command_length_stack (command_level) = command_line_length; command_iteration_stack (command_level) = iteration_level; iteration_level = base_iteration_level; temp_seg_usage_count (command_seg_stack (command_level)) = temp_seg_usage_count (command_seg_stack (command_level)) + 1; call revert_command_level; call get_quoted_string; command_char_stack (command_level) = command_char_number; i, command_seg_stack (command_level + 1) = command_seg_stack (colon_X_save_command_level); immediate_interrupt_ok = "0"b; command_line_address = temp_seg_address (i); command_char_number = command_char_stack (colon_X_save_command_level); command_line_length = command_length_stack (colon_X_save_command_level); base_iteration_level = iteration_level; iteration_level = command_iteration_stack (colon_X_save_command_level); command_level = command_level + 1; temp_seg_usage_count (quoted_string_seg_number) = temp_seg_usage_count (quoted_string_seg_number) + 1; i = current_Q_register_seg_number; current_Q_register_seg_number = quoted_string_seg_number; current_Q_register_value = quoted_string_length; if i ^= 0 then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1; goto command_complete; end; backslash: COMMAND (92): do; if num_arg = 0 then /* read the decimal number found to the right of the pointer */ do; num_arg = 1; current_expression = 0; if dot2 = end_buffer then goto backslash_0_args_number_not_found; j = verify (substr (buffer2, dot2 + 1, end_buffer - dot2), white_space) - 1; if j < 0 then goto backslash_0_args_number_not_found; temp_dot, i = dot2 + j; current_sign = 1; j = index ("+-", substr (buffer2, i + 1, 1)); if j ^= 0 then do; i = i + 1; if colon_flag ^= 0 then do; temp_dot = i; if j = 2 then current_sign = -1; end; if i = end_buffer then goto backslash_0_args_number_not_found; end; if colon_flag = 0 then j = verify (substr (buffer2, i + 1, end_buffer - i), "0123456789") - 1; else j = verify (substr (buffer2, i + 1, end_buffer - i), "01234567") - 1; if j < 0 then j = end_buffer - i; if j = 0 then goto backslash_0_args_number_not_found; i = i + j; if colon_flag = 0 then do; on fixedoverflow begin; current_expression = max_positive_integer; goto backslash_0_args_done; end; current_expression = convert (current_expression, substr (buffer2, temp_dot + 1, i - temp_dot)); backslash_0_args_done: revert fixedoverflow; end; else do; current_expression = cv_oct_check_ (substr (buffer2, temp_dot + 1, i - temp_dot), error_code); if error_code ^= 0 then do; error_code = 0; current_expression = max_positive_integer; end; if current_sign < 0 then current_expression = -current_expression; end; call move_dot_forward (i - dot2); goto command_return_value; end; else do; /* insert arg1 into text and pad with arg2-length(arg1) spaces */ if colon_flag = 0 then do; cvb = arg1; i = length (cvb) - verify (cvb, white_space) + 1; if num_arg = 2 then i = min (max (i, arg2), length (cvb)); call add_chars (addr (substr (cvb, length (cvb) - i + 1, i)), i); end; else do; call ioa_$rsnnl ("^o", string, i, arg1); if num_arg = 2 then call add_chars (addr (blanks), min (arg2 - i, length (blanks))); call add_chars (addr (string), i); end; go to command_complete; end; end backslash; no_room: error_message = "NO ROOM "; goto print_error_message; unimplemented_feature: error_message = "NOT IMPL"; goto print_error_message; label_not_found: error_message = "NO LABEL"; goto print_error_message; backslash_0_args_number_not_found: error_message = "\:NUMBR?"; goto print_error_message; A_1_arg_beyond_Z: dot_beyond_Z: error_message = "TOO BIG "; goto print_error_message; A_1_arg_before_0: bad_negative_argument: dot_before_0: error_message = "NEGATIVE"; goto print_error_message; unbalanced_parentheses: strange_parentheses: parenthesis_overflow: error_message = "PARENS "; goto print_error_message; skip_fail: error_message = "BAD SKIP"; goto print_error_message; iteration_overflow: iteration_underflow: unfinished_iteration: semi_colon_out_of_iteration: error_message = "BAD LOOP"; goto print_error_message; too_many_args: error_message = "MANY ARG"; goto print_error_message; too_few_args: error_message = "FEW ARGS"; goto print_error_message; Q_register_pushdown_underflow: error_message = "CANT POP"; goto print_error_message; Q_register_pushdown_overflow: command_level_overflow: string_too_long: EM_no_slot: error_message = "IMP.RES."; goto print_error_message; numeric_quoted_in_Q: ES_numeric_Q: M_numeric_Q_register: error_message = "numericQ"; goto print_error_message; percent_cant_increment: error_message = "% ? "; goto print_error_message; missing_double_quote_command: QUOTE_COMMAND (0): error_message = "BAD "" "; goto print_error_message; EXTERNAL_COMMAND (0): error_message = "BAD E "; goto print_error_message; missing_Q_register_name: illegal_Q_register_name: error_message = "Qreg ? "; goto print_error_message; COMMAND (0): COMMAND (1): COMMAND (2): COMMAND (3): COMMAND (4): COMMAND (5): COMMAND (6): COMMAND (7): COMMAND (8): COMMAND (9): COMMAND (11): COMMAND (12): COMMAND (13): COMMAND (14): COMMAND (15): COMMAND (16): COMMAND (17): COMMAND (18): COMMAND (19): COMMAND (20): COMMAND (21): COMMAND (22): COMMAND (23): COMMAND (24): COMMAND (25): COMMAND (26): COMMAND (27): COMMAND (28): COMMAND (29): COMMAND (30): COMMAND (31): COMMAND (32): COMMAND (35): COMMAND (37): COMMAND (38): COMMAND (40): COMMAND (42): COMMAND (45): COMMAND (46): COMMAND (47): COMMAND (48): COMMAND (49): COMMAND (50): COMMAND (51): COMMAND (52): COMMAND (53): COMMAND (54): COMMAND (55): COMMAND (56): COMMAND (57): COMMAND (58): COMMAND (63): COMMAND (64): COMMAND (66): COMMAND (81): COMMAND (89): COMMAND (90): COMMAND (94): COMMAND (95): COMMAND (96): COMMAND (98): COMMAND (113): COMMAND (121): COMMAND (122): COMMAND (123): COMMAND (124): COMMAND (125): COMMAND (126): COMMAND (127): error_message = current_character || ": ? "; /* illegal command */ goto print_error_message; illegal_delimiter: error_message = delimiter || ":DELIM?"; goto print_error_message; tty_no_read: no_more_temp_segs: error_message = "DISASTER"; goto print_error_message; args_wrong_order: error_message = "ORDER ? "; goto print_error_message; missing_right_operand: colon_X_not_in_macro: error_message = "? "; goto print_error_message; F_COMMAND (0): error_message = "BAD F "; goto print_error_message; EM_macro_not_found: ES_subroutine_not_found: file_error: call check_errset; call com_err_ (error_code, program_name, quoted_string); goto command_abort; fatal_S_fail: error_message = "S: fail "; goto print_error_message; print_error_message: call check_errset; if error_mode = "long" then call teco_error (error_message); else call WRITE (addr (error_structure), 0, length (error_message) + 1); goto command_abort; read_line: procedure; do while ("1"b); call READ (command_line_address, command_line_length); command_line_length = command_line_length + read_count; if command_line_length >= 2 /* See if this line ended with "$". */ then if substr (command_line, command_line_length - 1, 1) = "$" then do; command_line_length = command_line_length - 2; /* leave out the $ */ return; end; end; end read_line; get_character: procedure; /* modifies current_character, io_char, and */ /* command_char_number. */ command_char_number = command_char_number - backup_command_line_1_char; do while (command_char_number >= command_line_length); if command_level = 0 then goto get_character_fail_handler; call revert_command_level; end; current_character = substr (command_line, command_char_number + 1, 1); io_char = current_character; if trace_flag then if backup_command_line_1_char = 0 then call WRITE (io_char_address, 0, 1); command_char_number = command_char_number + 1; backup_command_line_1_char = 0; return; print_command_line: entry; search_successful = search_length ^= 0; if ^search_successful then search_length = command_line_length - command_char_number; if trace_flag then call WRITE (command_line_address, command_char_number, search_length); command_char_number = command_char_number + search_length; return; find_character: entry; do while (command_char_number >= command_line_length); if command_level = 0 then goto get_character_fail_handler; call revert_command_level; end; end get_character; check_errset: procedure; if iteration_level > 0 then do; do return_iteration_level = iteration_level by -1 to 1 while (^iteration.errset (return_iteration_level)); end; if return_iteration_level = 0 then return; do while (return_iteration_level <= base_iteration_level); call unwind_command_level; end; call unwind_iteration (return_iteration_level - 1); iteration_answer = 0; goto get_out_of_iteration; end; return; end check_errset; revert_command_level: procedure; dcl save_interrupt_ok bit (1) aligned; if iteration_level ^= base_iteration_level then goto unfinished_iteration; unwind_command_level: entry; save_interrupt_ok = immediate_interrupt_ok; immediate_interrupt_ok = "0"b; command_level = command_level - 1; temp_seg_usage_count (command_seg_stack (command_level + 1)) = temp_seg_usage_count (command_seg_stack (command_level + 1)) - 1; command_line_address = temp_seg_address (command_seg_stack (command_level)); command_char_number = command_char_stack (command_level); command_line_length = command_length_stack (command_level); base_iteration_level = command_iteration_stack (command_level); immediate_interrupt_ok = save_interrupt_ok; end revert_command_level; unwind_iteration: procedure (return_iteration_level); dcl return_iteration_level fixed bin (24); iteration_level = return_iteration_level; if iteration_level < base_iteration_level then goto unfinished_iteration; if iteration.end (iteration_level + 1) >= 0 then command_char_number = iteration.end (iteration_level + 1); else do; command_char_number = iteration.begin (iteration_level + 1); call skip ("<>"); end; return; end unwind_iteration; skip: procedure (search_chars); dcl search_chars char (2) aligned; trace_flag = "0"b; skip_with_trace: entry (search_chars); skip_count = 0; get_character_fail_handler = skip_fail; do while ("1"b); search_length = search (substr (command_line, command_char_number + 1), search_chars); call print_command_line; if search_successful then if substr (command_line, command_char_number, 1) = substr (search_chars, 2, 1) then do; /* Must search ending character first or "!" search fails. */ skip_count = skip_count - 1; if skip_count < 0 /* First unmatched end wins. */ then do; trace_flag = trace_flag_copy; return; end; end; else skip_count = skip_count + 1; call find_character; end; end skip; /* These entry points count lines either forward or in reverse. They change j, arg1, temp_dot, and count. */ must_find_line_forward: procedure; dcl must_find bit (1) aligned; must_find = "1"b; if "0"b then do; find_line_forward: entry; must_find = "0"b; end; temp_dot = dot2; count = end_buffer - dot2; /* Length if not all lines are found. */ do arg1 = 1 to arg1; /* arg1 is count of lines. */ if temp_dot >= end_buffer /* Obviously no more lines. */ then if must_find then goto dot_beyond_Z; else return; j = index (substr (buffer2, temp_dot + 1, end_buffer - temp_dot), new_line_char); if j = 0 then temp_dot = end_buffer; else temp_dot = temp_dot + j; end; count = temp_dot - dot2; /* Length of characters included. */ return; must_find_line_reverse: entry; must_find = "1"b; if "0"b then do; find_line_reverse: entry; must_find = "0"b; end; temp_dot = dot1; do arg1 = 1 to 1 - arg1; /* arg1 is negative count. */ j = 1; if temp_dot > 0 then do; j = index (reverse (substr (buffer1, 1, temp_dot)), new_line_char); if j = 0 then j = temp_dot + 1; end; temp_dot = temp_dot - j; end; temp_dot = temp_dot + 1; if temp_dot >= 0 then return; if must_find then goto dot_before_0; temp_dot = 0; end /* find_line */; get_quoted_string: procedure; /* procedure returns quoted_string */ dcl save_immediate_interrupt_ok bit (1) aligned, (quote_name, quote_seg, old_seg) fixed bin (24); call get_character; delimiter = current_character; if delimiter = "q" then goto quoted_string_in_Q_register; if delimiter = "Q" then goto quoted_string_in_Q_register; if delimiter >= "a" then if delimiter <= "z" then goto illegal_delimiter; if delimiter >= "0" then if delimiter <= "9" then goto illegal_delimiter; if delimiter >= "A" then if delimiter <= "Z" then goto illegal_delimiter; quote_name = quoted_string_Q_register_number; call allocate_Q_register_have_number (quote_name); get_character_fail_handler = no_quoting_delimiter; do while ("1"b); j = command_char_number; /* command_char_number is changed by "print_command_line". */ search_length = index (substr (command_line, j + 1, command_line_length - j), delimiter); call print_command_line; i = search_length - fixed (search_successful, 1, 0); /* Don't count delimiter. */ if i > 0 then do; if quoted_string_length + i > max_seg_size then goto string_too_long; substr (quoted_string, quoted_string_length + 1, i) = substr (command_line, j + 1, i); quoted_string_length = quoted_string_length + i; end; if search_successful then return; call find_character; if "0"b then do; no_quoting_delimiter: command_line_length = command_line_length + 2; call read_line; end; end; quoted_string_in_Q_register: quote_name = get_Q_register_number (); quote_seg = Q_register_seg_number (quote_name); if quote_seg = 0 then goto numeric_quoted_in_Q; save_immediate_interrupt_ok = immediate_interrupt_ok; immediate_interrupt_ok = "0"b; temp_seg_usage_count (quote_seg) = temp_seg_usage_count (quote_seg) + 1; old_seg = quoted_string_seg_number; quoted_string_seg_number = quote_seg; quoted_string_length = Q_register_value (quote_name); temp_seg_usage_count (old_seg) = temp_seg_usage_count (old_seg) - 1; immediate_interrupt_ok = save_immediate_interrupt_ok; end get_quoted_string; /* Procedure gets and checks the Q-register specified. */ get_Q_register_number: procedure () returns (fixed bin (24)); dcl Q_number fixed bin (24); get_character_fail_handler = missing_Q_register_name; call get_character; Q_number = fixed (unspec (io_char), 9, 0); if Q_number < lbound (Q_register_value, 1) then goto illegal_Q_register_name; if Q_number >= hbound (Q_register_value, 1) then goto illegal_Q_register_name; return (Q_number); end get_Q_register_number; /* procedure allocates a string register when required. */ allocate_Q_register: procedure (alloc_name); /* Enter here if Q-reg name is unknown. */ dcl (alloc_name, alloc_seg) fixed bin (24), save_immediate_interrupt_ok bit (1) aligned; alloc_name = get_Q_register_number (); allocate_Q_register_have_number: entry (alloc_name); /* Enter here if Q-reg name is known. */ save_immediate_interrupt_ok = immediate_interrupt_ok; immediate_interrupt_ok = "0"b; alloc_seg = Q_register_seg_number (alloc_name); if alloc_seg = 0 then goto must_allocate_Q_register; temp_seg_usage_count (alloc_seg) = temp_seg_usage_count (alloc_seg) - 1; if temp_seg_usage_count (alloc_seg) ^= 0 then do; must_allocate_Q_register: alloc_seg = number_reserved_temp_segs; find_free_seg: do; if alloc_seg >= hbound (temp_seg_address, 1) then goto no_more_temp_segs; alloc_seg = alloc_seg + 1; if temp_seg_usage_count (alloc_seg) ^= 0 then goto find_free_seg; end find_free_seg; Q_register_seg_number (alloc_name) = alloc_seg; if temp_seg_address (alloc_seg) = null then /* Formerly test for zero. See its dcl. */ do; call get_temp_seg_ (my_id, rwa_access, temp_seg_address (alloc_seg), error_code); if error_code ^= 0 then goto no_more_temp_segs; end; end; temp_seg_usage_count (alloc_seg) = 1; Q_register_value (alloc_name) = 0; immediate_interrupt_ok = save_immediate_interrupt_ok; end allocate_Q_register; READ: procedure (buffer_pointer, offset); dcl buffer_pointer ptr, (offset, length) fixed bin (24); p = buffer_pointer; if offset ^= 0 then p = addr (substr (p -> file, offset + 1, 1)); call iox_$get_line (iox_$user_input, p, max_seg_size - offset, read_count, error_code); in_chk: if error_code ^= 0 then goto io_diaster; if read_count = 0 then goto tty_no_read; return; READ_CHAR: entry; call iox_$get_chars (iox_$user_input, io_char_address, 1, read_count, error_code); goto in_chk; WRITE: entry (buffer_pointer, offset, length); p = buffer_pointer; if offset ^= 0 then p = addr (substr (p -> file, offset + 1, 1)); call iox_$put_chars (iox_$user_output, p, length, error_code); if error_code = 0 then return; io_diaster: call com_err_ (error_code, program_name); goto tty_no_read; end READ; move_dot: procedure (char_count, a_accept_error); dcl a_accept_error bit (1) aligned, accept_error bit (1) aligned init ("0"b), (char_count, cc, tc) fixed bin (24); accept_error = a_accept_error; if char_count > 0 /* Move forward if positive, backward if negative. */ then do; move_dot_forward: entry (char_count); /* Count must be positive or a nop. */ cc = char_count; if dot2 + cc > end_buffer then if accept_error then cc = end_buffer - dot2; else goto dot_beyond_Z; if cc <= 0 then return; immediate_interrupt_ok = "0"b; if max_dot1 - dot1 < cc /* Range of shared chars less than move count? */ then do; /* Yes, must move some or all of them. */ if max_dot1 - dot1 > 0 /* Some chars already moved? */ then do; /* Yes, indicate they were moved. */ tc = max_dot1 - dot1; dot1 = max_dot1; dot2 = dot2 + tc; cc = cc - tc; end; substr (buffer1, dot1 + 1, cc) = substr (buffer2, dot2 + 1, cc); max_dot1 = dot1 + cc; /* Increase upper bound of shared chars. */ if dot2 + cc = end_buffer then goto move_to_b1; /* If move empties buf2, share buf1. */ end; end; else do; /* Move count is <0 */ move_dot_backward: entry (char_count); /* Count must be negative or nop. */ cc = char_count; if -cc > dot1 then if accept_error then cc = -dot1; else goto dot_before_0; if cc >= 0 then return; immediate_interrupt_ok = "0"b; if dot2 - min_dot2 < -cc /* Range of shared chars less than move count? */ then do; /* Yes, must move some or all of them. */ if -cc <= dot2 /* Enough room in buf2 to make move? */ then do; /* Yes, prefix text to buf2. */ if dot2 - min_dot2 > 0 /* Some chars already moved? */ then do; /* Yes, indicate they were moved. */ tc = dot2 - min_dot2; dot1 = dot1 - tc; dot2 = min_dot2; cc = cc + tc; end; substr (buffer2, dot2 + (cc + 1), -cc) = substr (buffer1, dot1 + (cc + 1), -cc); min_dot2 = dot2 + cc; /* Decrease lower bound of shared chars. */ if min_dot2 + (dot1 + cc) = 0 /* Is buf1 empty and new buf2 offset zero? */ then do; /* Yes, share buffer2. */ max_dot1 = end_buffer; b1 = b2; n1 = n2; end; end; else do; /* No, move all of buf2 to buf1 and share buf1. */ if end_buffer - dot2 > 0 then substr (buffer1, dot1 + 1, end_buffer - dot2) = substr (buffer2, dot2 + 1, end_buffer - dot2); move_to_b1: end_buffer, max_dot1 = dot1 + (end_buffer - dot2); /* Share buffer1. */ b2 = b1; n2 = n1; min_dot2 = 0; dot2 = dot1; end; end; end; dot1 = dot1 + cc; /* Indicate move is complete. */ dot2 = dot2 + cc; end move_dot; /* Only call this entry to copy from the original segment to teco buffers. */ copy_source: procedure; dcl ichar char (ic) based unaligned, (source, in_ptr) ptr, (new_dot1, new_dot2, insert_count, n0, s1, s2, nd2, ic, new_end) fixed bin (24); ic = 0; /* Just copy segment without adding text and */ s1 = dot1; /* without deleting text. */ nd2 = dot2; goto copy_text; /* Call this entry to delete characters. */ delete_chars: entry (new_dot1, new_dot2); s1 = new_dot1; /* Number of characters to be left in buffer1. */ if s1 < 0 then goto dot_before_0; /* Validate our input. */ nd2 = new_dot2; /* New value of dot2. */ if nd2 > end_buffer then goto dot_beyond_Z; /* Validate our input. */ if s1 = dot1 & nd2 = dot2 then return; /* Delete count is zero. Do not change anything. */ ic = 0; /* Not adding text. */ goto copy_text; /* Call this entry to add characters. */ add_chars: entry (in_ptr, insert_count); ic = insert_count; /* Pick up length of text to be added. */ if ic = 0 then return; /* Length is zero. Do not change anything. */ s1 = dot1; /* Existing text will not be changed. */ nd2 = dot2; if s1 + end_buffer - nd2 + ic > max_seg_size then goto no_room; /* Can't add if segment size exceeded. */ copy_text: /* Text is moved only if b1 = b2. (Shared segment) */ s2 = end_buffer - nd2; /* Number of characters to be left in buffer2. */ immediate_interrupt_ok = "0"b; n0 = n1; /* Useful only if n1 = n2. (b1 = b2) */ if s2 = 0 | (s1 + ic + nd2) = 0 /* Buf2 empty or (buf1 empty and buf2 starts at 0). */ then do; n0 = n1; /* Indicates whether a close is required. */ end_buffer, max_dot1 = s1 + s2 + ic; /* Prepare to share a segment. */ min_dot2 = 0; /* Set total length and range of shared characters. */ if n1 = 0 /* Segment is user's segment. Copy it. */ then do; /* The copy will be shared. */ n1, n2 = 1; /* Pick an arbitrary temp seg. */ source = b1; /* Save pointer to user's segment. */ b1, b2 = temp_seg_address (1); /* Get pointer to new buffer. */ substr (b1 -> buffer1, 1, s1 + s2) = substr (source -> buffer1, 1, s1 + s2); /* Copy text. */ end; else do; /* Text is in two temp segs. Share one. */ if s2 > 0 /* All text in second buffer? */ then n1 = n2; /* Yes, share it. */ else n2 = n1; /* No, all in first so share it. */ b1, b2 = temp_seg_address (n1); /* Set both buffer pointers. */ end; end; else do; /* Text in both buffers or can't share buffer2. */ max_dot1 = s1 + ic; /* Shared text limits are current text position. */ min_dot2 = nd2; /* nd2 is still correct (end_buffer has not changed). */ if n1 = n2 /* Text must be move only if sharing a segment. */ then do; if n1 = 0 /* Shared segment is not temp seg. Move all text. */ then do; n1 = 1; n2 = 2; end; else if s1 < s2 /* Otherwise, move shorter piece of text. */ then n1 = 3 - n2; else n2 = 3 - n1; source = b1; /* Save pointer to original segment. */ b1 = temp_seg_address (n1); /* Assign new temp segments. */ b2 = temp_seg_address (n2); if s1 > 0 & n0 ^= n1 /* New seg for buf1 and text in buf1. */ then do; substr (b1 -> buffer1, 1, s1) = substr (source -> buffer1, 1, s1); end; if s2 > 0 & n0 ^= n2 /* New seg for buf2 and text in buf2. */ then do; new_end = min (divide (s1 + s2 + ic + 512 + 4095, 4096, 17, 0) * 4096, max_seg_size); if n1 ^= n2 then min_dot2 = new_end - s2; /* Change shared limit only if not shared. */ substr (b2 -> buffer2, new_end - s2 + 1, s2) = substr (source -> buffer2, end_buffer - s2 + 1, s2); end_buffer = new_end; end; end; end; dot1 = s1 + ic; dot2 = end_buffer - s2; /* Works even if end_buffer is changed. */ if ic > 0 then substr (b1 -> buffer1, s1 + 1, ic) = substr (in_ptr -> ichar, 1, ic); if n0 = 0 then goto close_a_file; return; close_file: entry (in_ptr); source = in_ptr; close_a_file: if source = null then return; call release_seg_ptr_ (source, -1, error_code); if error_code ^= 0 then goto file_error; end copy_source; end TECO;  teco_backup_file_.pl1 11/15/82 1907.0rew 11/15/82 1526.7 23643 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ teco_backup_file_: proc (file); /* Recoded by REMullen 8/20/73 to replicate call copy (file, file||.bak) */ dcl file char (*); dcl (d1, d2) char (168) aligned; /* dirnames */ dcl bdir char (168) aligned based; dcl (dirptr, entptr) ptr; dcl (e1, e2) char (32) aligned; /* entrynames */ dcl bent char (32) aligned based; dcl code fixed bin (35); /* standard system status code */ dcl e1_len fixed bin; /* length of first ename */ dcl dot_len fixed bin; /* length of first component of same */ dcl errname char (4) aligned init ("TECO"); /* for nd_handler's question */ dcl com_err_ ext entry options (variable); dcl expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl copy_seg_ ext entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (1) aligned, fixed bin (35)); dcl get_wdir_ ext entry () returns (char (168) aligned); dcl which_bit bit (1) aligned; /* 0 means err in d1>e1, 1 means d2>e2 */ dcl (min, substr, index, addr, length) builtin; /* --------------------------------------------------------- */ call expand_path_ (addr (file), length (file), addr (d1), addr (e1), code); if code ^= 0 then do; call com_err_ (code, errname, file); return; end; e1_len = index (e1, " "); if e1_len = 0 then e1_len = 32; /* were no blanks */ else e1_len = e1_len -1; /* last char was just before blank */ dot_len = index (e1, "."); /* only want first component in any case */ if dot_len = 0 then dot_len = 32; else dot_len = dot_len -1; e1_len = min (e1_len, dot_len); e2 = substr (e1, 1, e1_len) || ".bak"; /* make backup files name */ d2 = get_wdir_ (); /* it will go in working directory */ call copy_seg_ (d1, e1, d2, e2, errname, which_bit, code); /* try to make copy */ if code ^= 0 then do; if which_bit = "1"b then do; dirptr = addr (d2); entptr = addr (e2); end; else do; dirptr = addr (d1); entptr = addr (e1); end; call com_err_ (code, errname, "^a>^a", dirptr -> bdir, entptr -> bent); /* lose */ end; return; end;  teco_error.pl1 11/15/82 1907.0rew 11/15/82 1526.7 22536 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ teco_error: proc (error_string); dcl error_string char (*) unal; declare error_messages(22) char(64) internal static initial( /* <- 8 -><- 56 -> */ "S: fail Search failed.", "NO ROOM Text insertion would exceed maximum segment size.", "NOT IMPLUnimplemented feature or command.", "NO LABELLabel not found.", "TOO BIG Reference is beyond end of text.", "NEGATIVEReference is before beginning of text.", "PARENS Too many parentheses, or misplaced parenthesis.", "BAD LOOPInfinite loop, or misplaced <, >, or ;.", "MANY ARGToo many arguments.", "FEW ARGSToo few arguments.", "IMP.RES.Too many pushes or macros, or quoted string too long.", "numericQThis Q-register must contain text.", "% ? This Q-register must not contain text.", "BAD "" Illegal double quote command.", "BAD E Illegal external command.", "Qreg ? Missing or illegal Q-register name.", "DISASTERCannot read from teletype or out of storage.", "ORDER ? Arguments given in the wrong order.", "? Syntax error in expression or :X not in macro.", "\:NUMBR?Number does not appear following text pointer.", "CANT POPPushdown stack empty - cannot pop.", "BAD SKIPCharacter not found. Could not skip to >, ', or !."); dcl (hbound, length, substr) builtin; dcl message char(56); dcl name char(8) aligned; dcl i fixed bin; dcl ioa_ ext entry options (variable); name = error_string; /* Get exactly eight characters. */ if substr (name, 2) = ": ? " then do; message = "^a: illegal command."; goto print_message; end; if substr (name, 2) = ":DELIM?" then do; message = "^a: illegal quoting character."; goto print_message; end; do i = 1 to hbound(error_messages, 1); if name = substr(error_messages(i), 1, length(name)) then do; message = substr(error_messages(i), length(name)+1); goto print_message; end; end; message = "Error message not recognized."; print_message: call ioa_(message, substr(name, 1, 1)); return; end;  teco_get_macro_.pl1 11/15/82 1907.0rew 11/15/82 1526.7 40716 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ teco_get_macro_: procedure (macro_name, macro_address, macro_length, return_code); /* This procedure implements teco's search rules. There are several entry points: teco_get_macro_ - This entry point is called by teco to get a pointer to an external macro for an "em" command. teco_search - This entry point may be called using an "es" command and returns the full pathname of an external macro. teco_ssd - This entry point may be invoked as a command to change the second directory searched. If this entry point is not invoked or if the argument is a null string, the user's home directory will be searched. The directories searched by teco_get_macro_ are: 1. the current working directory 2. the user's directory, or any user specified directory 3. the containing directory for teco (called the teco library directory) Date last modified and reasons: 06/19/75 by David Levin to clean up and fix bugs 04/18/75 by David Levin to remove imbedded pathnames 04/21/72 by Peter Bishop to add teco_search and teco_ssd entries 06/27/71 by Richard H. Gumpertz for initial implementation */ get_macro_entry_flag = "1"b; arglen = length(macro_name); goto start_work; /* Secondary entry points. */ teco_ssd: entry; call cu_$arg_ptr(1, argptr, arglen, code); if code ^= 0 then do; call com_err_(code, "teco_ssd"); return; end; dir_name(2) = search_dir; return; teco_search: entry (macro_name, arg1, arg2, current_expression); get_macro_entry_flag = "0"b; arglen = index(macro_name, " ") - 1; /* Parameters - teco_get_macro_ */ dcl macro_name char(*) aligned, /* Macro name without "teco" suffix. (input) */ macro_address pointer, /* Pointer to segment containing the macro. (output) */ macro_length fixed bin(24), /* Character length of segment. (output) */ return_code fixed bin(35); /* Error code. (output) */ /* Parameters - teco_search */ dcl /* First argument declared above. (input/output) */ /* Macro name without "teco" suffix. (input) */ /* Full pathname of segment. (output) */ (arg1, arg2) fixed bin(24), /* not used */ current_expression fixed bin(24); /* Length of pathname. (output) */ /* Based */ dcl search_dir char(arglen) based(argptr); /* Automatic */ dcl arglen fixed bin, argptr ptr, bit_count fixed bin(24), code fixed bin(35), entry_name char(32) aligned, get_macro_entry_flag bit(1) aligned, i fixed bin, temp_ptr ptr; /* External Entries */ dcl com_err_ entry options(variable), cu_$arg_ptr entry(fixed bin, ptr, fixed bin, fixed bin(35)), get_seg_ptr_full_path_ entry(char(*), char(*) aligned, bit(6) aligned, fixed bin(24), ptr, fixed bin(35)), get_wdir_ entry() returns(char(168)), hcs_$fs_get_path_name entry(entry, char(*), fixed bin, char(*) aligned, fixed bin(35)), ioa_$rsnnl entry options(variable), user_info_$homedir entry(char(*)); /* Internal Static */ dcl r_access bit(6) aligned initial("010000"b) internal static, dir_name(3) char(168) initial((3) (168) " ") internal static; dcl (divide, hbound, index, length, null, reverse, substr) builtin; start_work: dir_name(1) = get_wdir_(); if substr(dir_name(2), 1, 4) = " " then call user_info_$homedir(dir_name(2)); if substr(dir_name(3), 1, 4) = " " then call hcs_$fs_get_path_name(teco_get_macro_, dir_name(3), i, entry_name, code); entry_name = substr(macro_name, 1, arglen); substr(entry_name, arglen+1, 5) = ".teco"; do i = 1 to hbound(dir_name, 1); call get_seg_ptr_full_path_ (dir_name (i), entry_name, r_access, bit_count, temp_ptr, code); if temp_ptr ^= null then if get_macro_entry_flag then do; macro_address = temp_ptr; macro_length = divide(bit_count+8, 9, 17, 0); return_code = code; return; end; else do; call ioa_$rsnnl("^a>^a", macro_name, current_expression, dir_name(i), entry_name); return; end; end; if get_macro_entry_flag then return_code = code; end teco_get_macro_;  get_temp_seg_.pl1 11/05/86 1509.8r w 11/04/86 1042.7 71370 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-10-17,Margolin), approve(86-10-17,MCR7549), audit(86-10-21,Lippard), install(86-10-30,MR12.0-1203): Module moved to bound_teco_ without change, but the installation tools demand a history comment. Better not to anger the gods. END HISTORY COMMENTS */ get_temp_seg_: procedure (a_id, a_acl, a_ptr, a_code); /* This procedure manages scratch segments in the user's process directory. It is absolutely immune to "quit"s and other methods of getting unexpected recursion. That is, one may quit out of get_temp_seg_, hold, and then call get_temp_seg_ again without risk of using the same segment twice. */ /* Last modified (Date and reason): by RHG on 17 July 1971 to redefine calls to be more usable by recursive procedures by Richard H. Gumpertz on 10 July 1971 for initial implementation */ /* */ declare a_id bit (36) aligned, a_acl bit (5) aligned, a_ptr ptr, a_code fixed bin (35); declare name_buffer char (32) aligned, name_len fixed bin, name based (addr (name_buffer)) aligned char (name_len); declare (i, j) fixed bin, p pointer, first_time bit (1) aligned init ("1"b) int static, process_dir char (168) aligned int static, error_code fixed bin(35), error_code2 fixed bin(35), id bit (36) aligned, rings (3) fixed bin, acl fixed bin (5); declare (addr, bit, fixed, hbound, null, stac, substr, unspec) builtin; declare temp_seg_list_ptr init (null) int static ptr, 1 temp_seg_list (0:4095) based (temp_seg_list_ptr) aligned, 2 temp_seg, 3 used bit (36) aligned, 3 acl fixed bin (5), 3 ptr ptr, 2 proc_id, 3 name char (32) aligned, 3 stack_ptr ptr, 3 count fixed bin, 3 used bit (36) aligned; declare hcs_$make_seg entry (char(*) aligned, char(*) aligned, char(*) aligned, fixed bin (5), ptr, fixed bin(35)), hcs_$add_acl_entries entry(char(*) aligned, char(*) aligned, ptr, fixed bin, fixed bin(35)), hcs_$truncate_seg entry (ptr, fixed bin, fixed bin(35)), cu_$level_get entry () returns (fixed bin), cu_$stack_frame_ptr entry () returns (pointer), get_group_id_$tag_star entry returns(char(32) aligned), get_pdir_ entry () returns (char (168) aligned), ioa_$rsnnl entry options (variable); declare (error_table_$notalloc, error_table_$not_seg_type) external fixed bin(35); declare 1 seg_acl aligned, 2 access_name char(32), 2 modes bit(36), 2 zero_pad bit(36), 2 error_code fixed bin(35); /* */ %include stack_frame; /* */ /* get_temp_seg_: entry (a_id, a_acl, a_ptr, a_code); /* remember the proc statement above */ acl = fixed (a_acl, 5); id = a_id; a_ptr = null; if first_time then call init; do i = 0 to hbound (temp_seg, 1); check_new_seg: if i >= proc_id.count (0) then do; proc_id.count (0) = proc_id.count (0) + 1; goto check_new_seg; end; if stac (addr (temp_seg.used (i)), id) then do; if unspec (temp_seg.ptr (i)) = ""b then /* get a segment if we don't already have one */ do; call ioa_$rsnnl ("temp_seg_.^d.^d", name_buffer, name_len, cu_$level_get(), (i)); temp_seg.acl (i) = acl; call hcs_$make_seg (process_dir, name, "", acl, p, error_code); if p = null then goto error; temp_seg.ptr (i) = p; end; else if acl ^= temp_seg.acl (i) then do; call change_acl; if error_code ^= 0 then goto error; end; a_ptr = temp_seg.ptr (i); a_code = 0; return; end; end; a_code = error_table_$notalloc; return; /* */ assign_temp_seg_id_: entry (a_proc_id, a_id, a_code); declare a_proc_id char (*); if first_time then call init; do i = 1 to hbound (proc_id, 1); /* note that i = 0 is illegal */ if stac (addr (proc_id.used (i)), "1"b) then do; proc_id.name (i) = a_proc_id; proc_id.stack_ptr (i) = cu_$stack_frame_ptr () -> stack_frame.prev_sp; a_id = bit (fixed (proc_id.count (i), 18), 18) || bit (fixed (i, 18)); a_code = 0; return; end; end; a_code = error_table_$notalloc; a_id = "1"b; /* just in case he uses it anyways */ return; /* */ release_temp_seg_: entry (a_id, a_ptr, a_code); if first_time then call init; id = a_id; if id = ""b then id = "1"b; p = a_ptr; do i = 0 to proc_id.count (0)+1; if temp_seg.ptr (i) = p then /* release it if this is the one */ do; if temp_seg.used (i) = id then do; acl = 01011b; if temp_seg.acl (i) ^= acl then do; call change_acl; if error_code ^= 0 then goto error; end; call hcs_$truncate_seg (p, 0, error_code); if error_code ^= 0 then goto error; temp_seg.used (i) = ""b; end; a_code = 0; return; end; end; a_code = error_table_$not_seg_type; return; /* */ release_temp_segs_all_: entry (a_id, a_code); a_code = 0; id = a_id; j = fixed (substr (id, 19, 18), 18); if j = 0 then return; if first_time then call init; do i = 0 to proc_id.count (0)+1; if temp_seg.used (i) = id then do; error_code, error_code2 = 0; if unspec (temp_seg.ptr (i)) then do; acl = 01011b; if temp_seg.acl (i) ^= acl then call change_acl; if error_code ^= 0 then a_code = error_code; call hcs_$truncate_seg (temp_seg.ptr (i), 0, error_code2); if error_code2 ^= 0 then if error_code = 0 then a_code = error_code2; end; if error_code = 0 then if error_code2 = 0 then temp_seg.used (i) = ""b; end; if a_code = 0 then if fixed (substr (id, 1, 18), 18) = proc_id.count (j) then do; proc_id.count (j) = proc_id.count (j) + 1; proc_id.used (j) = ""b; end; end; return; /* */ list_temporary_segments: list_temp_segs: lts: entry; declare none_used bit (1) aligned, ioa_ external entry options (variable); if first_time then call init; none_used = "1"b; do i = 0 to proc_id.count (0)+1; if temp_seg.used (i) then /* print it only if it is in use */ do; if none_used then /* print the header the first time only */ do; call ioa_ ("name seg_ptr proc_id stack proc_name"); none_used = "0"b; end; j = fixed (substr (temp_seg.used (i), 19, 18), 18); call ioa_ ("temp_seg_.^d.^d ^p ^w ^p ^a", cu_$level_get(), (i), temp_seg.ptr (i), temp_seg.used (i), proc_id.stack_ptr (j), proc_id.name (j)); end; end; if none_used then call ioa_ ("no temporary segments in use"); return; /* */ init: proc; process_dir = get_pdir_ (); call ioa_$rsnnl ("temp_seg_.^d.list", name_buffer, name_len, cu_$level_get()); call hcs_$make_seg (process_dir, name, "", 1011b, temp_seg_list_ptr, error_code); if temp_seg_list_ptr = null then goto error; proc_id.name (0) = "****no name given***"; proc_id.stack_ptr (0) = null; first_time = ""b; end init; change_acl: proc; rings (1), rings (2), rings (3) = cu_$level_get (); call ioa_$rsnnl ("temp_seg_.^d.^d", name_buffer, name_len, cu_$level_get(), (i)); temp_seg.acl (i) = -1; /* just in case we get quit out of */ seg_acl.access_name = get_group_id_$tag_star(); seg_acl.modes = substr(bit(acl,5), 2, 3); seg_acl.zero_pad = "0"b; call hcs_$add_acl_entries(process_dir, name, addr(seg_acl), 1, error_code); if error_code = 0 then temp_seg.acl (i) = acl; end; error: a_code = error_code; return; /* */ end; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved